Tangence-0.28000755001750001750 014174566136 11725 5ustar00leoleo000000000000Tangence-0.28/Build.PL000444001750001750 177414174566136 13367 0ustar00leoleo000000000000use v5; use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Tangence', requires => { 'perl' => '5.026', 'Encode' => 0, 'Exporter' => '5.57', 'experimental' => 0, 'Feature::Compat::Try' => 0, 'Future' => '0.36', 'Future::AsyncAwait' => '0.47', 'List::Util' => '1.29', 'Object::Pad' => '0.51', 'Parser::MGC' => '0.04', 'Struct::Dumb' => 0, 'Sub::Util' => '1.40', 'Syntax::Keyword::Dynamically' => 0, 'Syntax::Keyword::Match' => '0.06', }, test_requires => { 'Struct::Dumb' => '0.09', 'Test::Fatal' => '0.006', 'Test::HexString' => 0, 'Test::Identity' => 0, 'Test::Memory::Cycle' => 0, 'Test::More' => '0.88', # done_testing 'Test::Refcount' => 0, }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, license => 'perl', create_license => 1, create_readme => 1, ); $build->create_build_script; Tangence-0.28/Changes000444001750001750 1522614174566136 13403 0ustar00leoleo000000000000Revision history for Tangence 0.28 2022-01-27 [CHANGES] * Look for the `isbool` function in perl core's `builtin::` namespace, rather than the short-lived and now removed Scalar::Util version 0.27 2021-10-18 [CHANGES] * General code modernisation: + Use signatures from perl v5.26 + Use Object::Pad in most classes + Use Future::AsyncAwait + Use Syntax::Keyword::Dynamically + Use Syntax::Keyword::Match in more places * Rename the memoizing constructors to `->make` to avoid clashing with the generated ones from Object::Pad 0.26 2021-09-12 [CHANGES] * General code modernisation: + Use Syntax::Keyword::Match instead of given/when + Use Feature::Compat::Try instead of eval {} + use VERSION in every .pm file * Support core booleans in 'any' type packing * Ensure that boolean stream values unpack to real booleans [BUGFIXES] * Depend on Future >= 0.36 for ->retain method (RT131471) 0.25 2020-01-14 [CHANGES] * Allow servers to disallow access to Registry * Disallow clients from accessing objects that haven't already been sent to them * Customisable root object per connection * Added $client->get_registry; discourage the ->registry method * Use core's Sub::Util::set_subname() * Removed support for protocol minor version 2 [BUGFIXES] * Ensure MSG_SETPROP serialises correctly for non-scalar properties 0.24 2017-11-14 17:48:45 [BUGFIXES] * Avoid harmless warning about wide characters during SvIV test 0.23 2017/01/09 13:40:23 [BUGFIXES] * Fix handling of Inf and NaN float values to work on perl versions other than 5.22 (RT118806) 0.22 2016/11/16 23:38:38 [CHANGES] * Rename 'iterators' to 'cursors' * Document and support Inf and NaN float values, including on float16 * Support perl 5.24's lack of "." in @INC 0.21 2015/10/28 21:07:15 [BREAKING CHANGES] * Large API-breaking changes in Tangence::ObjectProxy - now works entirely through Futures instead of one-shot continuation callbacks 0.20 2014/08/13 23:23:11 [CHANGES] * Better support for late declaration of Tangence class definitions after the main tanfile is loaded [BUGFIXES] * Fix 'return or' operator precedence (RT97483) * Compare floats by approximation during unit tests (RT94404) * Fix block folding in syntax/tangence.vim 0.19 2014/03/30 13:33:40 [CHANGES] * Created new Tangence::Type classes to represent the type system as firstclass objects * Have Tangence::Type provide a suitable default value for uninitialised properties * Move most of the value pack/unpack code out of Tangence::Message into the Type classes * Support floating-point numbers as a native format * Pack/unpack smashed objects using type-specific serialisation [BUGFIXES] * Quiet 'experimental' warnings about given/when 0.18 BUGFIXES: * Handle void-returning method signatures correctly (RT#83637) 0.17 CHANGES: * Minimal minor version 2 * Expose ->class and ->can_method / ->can_event / ->can_property on both Tangence::Object and Tangence::ObjectProxy 0.16 CHANGES: * Bumped wire protocol minor version to 3: + Support GETPROPELEM operation + Support WATCH_ITER for queue property iteration * Internal rewrites to some unit tests for neatness 0.15 BUGFIXES: * Fix Tangence::Message on clientside when dealing with minor version 2 servers, by actually 'use'ing classes it requires 0.14 CHANGES: * Bumped wire protocol minor version to 2: + Provide wire-level struct record serialisations + Encode classes as structs rather than use introspection dict * Recognise struct definitions in the tanfile parser * Minimum supported minor protocol version is now 1; minor version 0 is no longer supported 0.13 CHANGES: * Bumped wire protocol minor version to 1: + Encode strings on the wire (dict keys and class names) as Tangence strings + Give classes ID numbers to refer to in CONSTRUCT messages, rather then full class name every time 0.12 CHANGES: * Defined MSG_INIT for server/client version negitiations * Implement it in the server, but not yet in the client as it crashes pre 0.12 servers * Implement types as first-class metadata values BUGFIXES: * Implement respondERROR since it is actually being used 0.11 BUGFIXES: * Handle UPDATE messages on objset properties correctly 0.10 BUGFIXES: * Fix memory cycle testing bug 0.09 CHANGES: * Renaming/reworking of internal metadata classes * Optionally use Sub::Name to apply names to subscription / watch callbacks 0.08 CHANGES: * Optionally use Sub::Name to name generated property accessor/mutator methods * Further improvements to metadata layer 0.07 CHANGES: * Redesign of metadata layer to use real objects rather than unblessed hashrefs for structural information * Optionally parse (but currently ignore) argument names in methods and events * Created a parse+dump script to test the parser 0.06 CHANGES: * Look up Tangence interface metadata from a specified file, rather than per-class package variables. * Added Tangence::Compiler::Parser 0.05 CHANGES: * Added documentation to some of the classes * Moved the Net::Async::Tangence tree into its own module 0.04 CHANGES: * Properly split out lower-level abstract Tangence code, from IO::Async-based Net::Async::Tangence wrappers * Added some initial documentation to Tangence::Stream, ::Client and ::Server 0.03 CHANGES: * Weaken references between objects and connections to remove memory cycles * Move all the IO::Async-based code into its own namespace tree of Net::Async::Tangence 0.02 CHANGES: * New Meta::Class introspection objects * Bugfixes for test reliability due to the way stream writes/reads get split 0.01 First version, released on an unsuspecting world. Tangence-0.28/LICENSE000444001750001750 4376214174566136 13123 0ustar00leoleo000000000000This software is copyright (c) 2022 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2022 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) 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. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2022 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Tangence-0.28/MANIFEST000444001750001750 241714174566136 13217 0ustar00leoleo000000000000bin/tangence-dumptan Build.PL Changes contrib/vim/ftdetect/tangence.vim contrib/vim/syntax/tangence.vim doc/00-overview.txt doc/01-serverclient.txt doc/02-datamodel.txt doc/03-objectmodel.txt doc/04-serialisation.txt doc/05-wireprotocol.txt lib/Tangence.pm lib/Tangence/Class.pm lib/Tangence/Client.pm lib/Tangence/Compiler/Parser.pm lib/Tangence/Constants.pm lib/Tangence/Message.pm lib/Tangence/Meta/Argument.pm lib/Tangence/Meta/Class.pm lib/Tangence/Meta/Event.pm lib/Tangence/Meta/Field.pm lib/Tangence/Meta/Method.pm lib/Tangence/Meta/Property.pm lib/Tangence/Meta/Struct.pm lib/Tangence/Meta/Type.pm lib/Tangence/Object.pm lib/Tangence/ObjectProxy.pm lib/Tangence/Property.pm lib/Tangence/Registry.pm lib/Tangence/Server.pm lib/Tangence/Server/Context.pm lib/Tangence/Stream.pm lib/Tangence/Struct.pm lib/Tangence/Type.pm lib/Tangence/Types.pm MANIFEST This list of files t/00use.t t/01compiler-parser.t t/02registry.t t/03properties.t t/10message.t t/11stream.t t/20server.t t/21client.t t/22xlink.t t/23close.t t/30props-cbs.t t/31props-cache.t t/32props-cursor.t t/33props-set.t t/40server-security.t t/90close-leak.t t/99pod.t t/Ball.pm t/Ball.tan t/Colourable.pm t/Colourable.tan t/Conversation.pm t/TestObj.pm t/TestObj.tan t/TestServerClient.pm README LICENSE META.yml META.json Tangence-0.28/META.json000444001750001750 1047314174566136 13530 0ustar00leoleo000000000000{ "abstract" : "attribute-oriented server/client object remoting framework", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4231", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Tangence", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "Encode" : "0", "Exporter" : "5.57", "Feature::Compat::Try" : "0", "Future" : "0.36", "Future::AsyncAwait" : "0.47", "List::Util" : "1.29", "Object::Pad" : "0.51", "Parser::MGC" : "0.04", "Struct::Dumb" : "0", "Sub::Util" : "1.40", "Syntax::Keyword::Dynamically" : "0", "Syntax::Keyword::Match" : "0.06", "experimental" : "0", "perl" : "5.026" } }, "test" : { "requires" : { "Struct::Dumb" : "0.09", "Test::Fatal" : "0.006", "Test::HexString" : "0", "Test::Identity" : "0", "Test::Memory::Cycle" : "0", "Test::More" : "0.88", "Test::Refcount" : "0" } } }, "provides" : { "Tangence" : { "file" : "lib/Tangence.pm", "version" : "0.28" }, "Tangence::Class" : { "file" : "lib/Tangence/Class.pm", "version" : "0.28" }, "Tangence::Client" : { "file" : "lib/Tangence/Client.pm", "version" : "0.28" }, "Tangence::Compiler::Parser" : { "file" : "lib/Tangence/Compiler/Parser.pm", "version" : "0.28" }, "Tangence::Constants" : { "file" : "lib/Tangence/Constants.pm", "version" : "0.28" }, "Tangence::Message" : { "file" : "lib/Tangence/Message.pm", "version" : "0.28" }, "Tangence::Meta::Argument" : { "file" : "lib/Tangence/Meta/Argument.pm", "version" : "0.28" }, "Tangence::Meta::Class" : { "file" : "lib/Tangence/Meta/Class.pm", "version" : "0.28" }, "Tangence::Meta::Event" : { "file" : "lib/Tangence/Meta/Event.pm", "version" : "0.28" }, "Tangence::Meta::Field" : { "file" : "lib/Tangence/Meta/Field.pm", "version" : "0.28" }, "Tangence::Meta::Method" : { "file" : "lib/Tangence/Meta/Method.pm", "version" : "0.28" }, "Tangence::Meta::Property" : { "file" : "lib/Tangence/Meta/Property.pm", "version" : "0.28" }, "Tangence::Meta::Struct" : { "file" : "lib/Tangence/Meta/Struct.pm", "version" : "0.28" }, "Tangence::Meta::Type" : { "file" : "lib/Tangence/Meta/Type.pm", "version" : "0.28" }, "Tangence::Object" : { "file" : "lib/Tangence/Object.pm", "version" : "0.28" }, "Tangence::ObjectProxy" : { "file" : "lib/Tangence/ObjectProxy.pm", "version" : "0.28" }, "Tangence::Property" : { "file" : "lib/Tangence/Property.pm", "version" : "0.28" }, "Tangence::Registry" : { "file" : "lib/Tangence/Registry.pm", "version" : "0.28" }, "Tangence::Server" : { "file" : "lib/Tangence/Server.pm", "version" : "0.28" }, "Tangence::Server::Context" : { "file" : "lib/Tangence/Server/Context.pm", "version" : "0.28" }, "Tangence::Stream" : { "file" : "lib/Tangence/Stream.pm", "version" : "0.28" }, "Tangence::Struct" : { "file" : "lib/Tangence/Struct.pm", "version" : "0.28" }, "Tangence::Type" : { "file" : "lib/Tangence/Type.pm", "version" : "0.28" }, "Tangence::Types" : { "file" : "lib/Tangence/Types.pm", "version" : "0.28" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.28", "x_serialization_backend" : "JSON::PP version 4.04" } Tangence-0.28/META.yml000444001750001750 553714174566136 13345 0ustar00leoleo000000000000--- abstract: 'attribute-oriented server/client object remoting framework' author: - 'Paul Evans ' build_requires: Struct::Dumb: '0.09' Test::Fatal: '0.006' Test::HexString: '0' Test::Identity: '0' Test::Memory::Cycle: '0' Test::More: '0.88' Test::Refcount: '0' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Tangence provides: Tangence: file: lib/Tangence.pm version: '0.28' Tangence::Class: file: lib/Tangence/Class.pm version: '0.28' Tangence::Client: file: lib/Tangence/Client.pm version: '0.28' Tangence::Compiler::Parser: file: lib/Tangence/Compiler/Parser.pm version: '0.28' Tangence::Constants: file: lib/Tangence/Constants.pm version: '0.28' Tangence::Message: file: lib/Tangence/Message.pm version: '0.28' Tangence::Meta::Argument: file: lib/Tangence/Meta/Argument.pm version: '0.28' Tangence::Meta::Class: file: lib/Tangence/Meta/Class.pm version: '0.28' Tangence::Meta::Event: file: lib/Tangence/Meta/Event.pm version: '0.28' Tangence::Meta::Field: file: lib/Tangence/Meta/Field.pm version: '0.28' Tangence::Meta::Method: file: lib/Tangence/Meta/Method.pm version: '0.28' Tangence::Meta::Property: file: lib/Tangence/Meta/Property.pm version: '0.28' Tangence::Meta::Struct: file: lib/Tangence/Meta/Struct.pm version: '0.28' Tangence::Meta::Type: file: lib/Tangence/Meta/Type.pm version: '0.28' Tangence::Object: file: lib/Tangence/Object.pm version: '0.28' Tangence::ObjectProxy: file: lib/Tangence/ObjectProxy.pm version: '0.28' Tangence::Property: file: lib/Tangence/Property.pm version: '0.28' Tangence::Registry: file: lib/Tangence/Registry.pm version: '0.28' Tangence::Server: file: lib/Tangence/Server.pm version: '0.28' Tangence::Server::Context: file: lib/Tangence/Server/Context.pm version: '0.28' Tangence::Stream: file: lib/Tangence/Stream.pm version: '0.28' Tangence::Struct: file: lib/Tangence/Struct.pm version: '0.28' Tangence::Type: file: lib/Tangence/Type.pm version: '0.28' Tangence::Types: file: lib/Tangence/Types.pm version: '0.28' requires: Encode: '0' Exporter: '5.57' Feature::Compat::Try: '0' Future: '0.36' Future::AsyncAwait: '0.47' List::Util: '1.29' Object::Pad: '0.51' Parser::MGC: '0.04' Struct::Dumb: '0' Sub::Util: '1.40' Syntax::Keyword::Dynamically: '0' Syntax::Keyword::Match: '0.06' experimental: '0' perl: '5.026' resources: license: http://dev.perl.org/licenses/ version: '0.28' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Tangence-0.28/README000444001750001750 64514174566136 12727 0ustar00leoleo000000000000NAME Tangence - attribute-oriented server/client object remoting framework DESCRIPTION Like CORBA only much smaller, lighter, and with heavy emphasis on attributes of remoted objects, including notifications of modification and atomic update operations. TODO Docs. Other languages. Static metadata. Other metadata backend generation - Moose? AUTHOR Paul Evans Tangence-0.28/bin000755001750001750 014174566136 12475 5ustar00leoleo000000000000Tangence-0.28/bin/tangence-dumptan000444001750001750 500114174566136 16003 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; package DumperParser; use base qw( Tangence::Compiler::Parser ); sub make_class { shift; DumperParser::Class->new( @_ ) } sub make_method { shift; DumperParser::Method->new( @_ ) } sub make_event { shift; DumperParser::Event->new( @_ ) } sub make_property { shift; DumperParser::Property->new( @_ ) } sub make_argument { shift; DumperParser::Argument->new( @_ ) } package DumperParser::Class; use base qw( Tangence::Meta::Class ); sub _vals { my $h = shift; map { $h->{$_} } sort keys %$h } sub as_text { my $self = shift; join "\n", "class ".$self->name." {", ( map { " isa ".$_->name.";" } $self->direct_superclasses ), ( map { " " . $_->as_text } _vals $self->direct_methods ), ( map { " " . $_->as_text } _vals $self->direct_events ), ( map { " " . $_->as_text } _vals $self->direct_properties ), "}\n"; } package DumperParser::Method; use base qw( Tangence::Meta::Method ); sub as_text { my $self = shift; join "", "method ", $self->name, "(", join( ",", map { $_->as_text } $self->arguments ), ")", defined $self->ret ? ( " -> ", $self->ret->sig ) : (), ";"; } package DumperParser::Event; use base qw( Tangence::Meta::Event ); sub as_text { my $self = shift; join "", "event ", $self->name, "(", join( ",", map { $_->as_text } $self->arguments ), ");", } package DumperParser::Property; use base qw( Tangence::Meta::Property ); use Tangence::Constants; my %dimnames = ( DIM_SCALAR, "scalar", DIM_HASH, "hash", DIM_ARRAY, "array", DIM_QUEUE, "queue", DIM_OBJSET, "objset", ); sub as_text { my $self = shift; my $dimension = $self->dimension; join "", ( $self->smashed ? "smashed " : () ), "prop ", $self->name, " = ", ( $dimension == DIM_SCALAR ? () : ( $dimnames{$dimension} . " of " ) ), $self->type->sig, ";"; } package DumperParser::Argument; use base qw( Tangence::Meta::Argument ); sub as_text { my $self = shift; return join " ", $self->type->sig, ( defined $self->name ? $self->name : () ); } package main; my $parser = DumperParser->new; my $meta = $parser->from_file( $ARGV[0] ); # TODO: This needs to be sorted in a better order for dependencies, or else # make the compiler parser able to handle out-of-order dependencies foreach my $class ( sort keys %$meta ) { print $meta->{$class}->as_text; print "\n"; } Tangence-0.28/contrib000755001750001750 014174566136 13365 5ustar00leoleo000000000000Tangence-0.28/contrib/vim000755001750001750 014174566136 14160 5ustar00leoleo000000000000Tangence-0.28/contrib/vim/ftdetect000755001750001750 014174566136 15762 5ustar00leoleo000000000000Tangence-0.28/contrib/vim/ftdetect/tangence.vim000444001750001750 12014174566136 20371 0ustar00leoleo000000000000" Set Tangence IDL filetype au BufNewFile,BufRead *.tan set filetype=tangence Tangence-0.28/contrib/vim/syntax000755001750001750 014174566136 15506 5ustar00leoleo000000000000Tangence-0.28/contrib/vim/syntax/tangence.vim000444001750001750 404014174566136 20142 0ustar00leoleo000000000000" Periods are allowed in identifiers setlocal isident+=. syntax keyword TangenceKeyword include smashed of syntax match TangenceComment /#.*/ syntax match TangenceString /"\(\\.\|[^"]\)*"/ syntax keyword TangenceKeyword class nextgroup=TangenceClassName skipwhite syntax match TangenceClassName /\i\+/ nextgroup=TangenceClassBlock skipwhite contained syntax keyword TangenceKeyword struct nextgroup=TangenceStructName skipwhite syntax match TangenceStructName /\i\+/ nextgroup=TangenceStructBlock skipwhite contained syntax match TangenceType /\i\+/ contained syntax match TangenceIdentifier /\i\+/ contained syntax keyword TangenceKeyword isa nextgroup=TangenceType skipwhite syntax keyword TangenceKeyword method nextgroup=TangenceIdentifier,TangenceArglist skipwhite syntax keyword TangenceKeyword event nextgroup=TangenceIdentifier,TangenceArglist skipwhite syntax keyword TangenceKeyword prop nextgroup=TangenceIdentifier skipwhite syntax keyword TangenceKeyword field nextgroup=TangenceIdentifier skipwhite syntax keyword TangenceDim scalar hash queue array objset syntax keyword TangenceType bool int float str obj any syntax region TangenceType start=/\(list\|dict\)(/ end=/)/ contains=TangenceType syntax region TangenceArglist start="(" end=")" contains=TangenceType,TangenceIdentifier skipwhite syntax region TangenceClassBlock start="{" end="}" fold transparent contained syntax region TangenceStructBlock start="{" end="}" fold transparent contained if version >= 508 || !exists("did_tangence_syn_inits") if version < 508 let did_tangence_syn_inits = 1 command -nargs=+ HiLink hi link else command -nargs=+ HiLink hi def link endif HiLink TangenceComment Comment HiLink TangenceKeyword Keyword HiLink TangenceString String HiLink TangenceClassName Identifier HiLink TangenceStructName Identifier HiLink TangenceIdentifier Identifier HiLink TangenceDim StorageClass HiLink TangenceType Type delcommand HiLink endif set foldmethod=syntax set foldcolumn=2 Tangence-0.28/doc000755001750001750 014174566136 12472 5ustar00leoleo000000000000Tangence-0.28/doc/00-overview.txt000444001750001750 146614174566136 15462 0ustar00leoleo000000000000An overview of Tangence ======================= Tangence is all of the following: 1. A single server/multiple client protocol for sharing information about objects. 2. A data model - it defines the types of values that are transmitted between the server and clients. 3. An object model - it defines the abstract look-and-feel of objects that are visible in the server end, and the proxies to them that exist in the client ends. 4. A wire protocol - it defines the bits down the wire of some stream. 5. A collection of Perl modules (a Perl distribution) which implements all of the above. These writings may sometimes suffer the "Java problem"; the problem of the same name being applied to too many different concepts. I'll try to make the context or wording clear to minimise confusions. Tangence-0.28/doc/01-serverclient.txt000444001750001750 165114174566136 16316 0ustar00leoleo0000000000001. Server/Client ---------------- In a Tangence system, one program is distinct in being the server. It is the program that hosts the actual objects being considered. It is also the program that holds the networking socket to which the clients connect. The other programs are all clients, which connect to the server. While each client is notionally distinct, they all share access to the same objects within the server. The clients are not directly aware of each other's existence, though each one's effects on the system may be visible to the others as a result of calling methods or altering properties on the objects. Internally, the clients will use proxy objects through which to access the objects in the server. There will be a one-to-one correspondance between server objects and client proxies. Not every server object needs to have a corresponding proxy in every client - proxies are created lazily when they are required. Tangence-0.28/doc/02-datamodel.txt000444001750001750 365614174566136 15553 0ustar00leoleo0000000000002. Data Model ------------- Whenever a value is sent across the connection between the server and a client, that value has a fixed type. The underlying streaming layer recognises the following fundamental types of values. Each type has a string to identify call it, called the signature. These are used by introspection data; see later. * Booleans Uses the type signature "bool". * Integers, both signed and unsigned, in 8, 16, 32 and 64bit lengths An integer of unspecified size uses the type signature "int". Specific sized integers use the type signatures "s8", "s16", "s32", "s64", "u8", "u16", "u32", "u64" * Floating-point numbers, in 16, 32 and 64bit lengths A float of unspecified size uses the type signature "float". Specific sized floats use the type signatures "float16", "float32", "float64" Note that the Intel-specific 80bit "extended double" format is not supported * Unicode strings Uses the type signature "str". * References to Tangence objects Uses the type signature "obj". * Lists of values Uses the type signature "list(T)" where T is the type signature of its element type. * Dictionaries of (string) named keys to values Uses the type signature "dict(T)" where T is the type signature of its element type. * Structured records of values Uses a type signature giving the name of the structure type. * For type signatures, there is also the type of "any", which allows any type. As Tangence is primarily an interprocess-communication layer, its main focus is that of communication. The Data Model applies transiently, to data as it is in transit between the server and a client. A consequence here is that it only considers the surface value of the types of data, rather than any deeper significance. It does not preserve self-referential data, nor can it cope with cyclic structures. More complex shaped data should be represented by real Tangence objects. Tangence-0.28/doc/03-objectmodel.txt000444001750001750 1260614174566136 16124 0ustar00leoleo0000000000003. Object Model --------------- In Tangence, the primary item of interaction is an object. Tangence objects exist in the server, most likely bearing at least some relationship to some native objects in the server implementation (though if and when the occasion ever arises that a C program can host a Tangence server, obviously this association will be somewhat looser). In the server, two special objects exist - one is the Root object, the other is the Repository. These are the only two well-known objects that the client knows always exist. All the other objects are initially accessed via these. The client(s) interact with the server almost entirely by performing operations on objects. When the client connects to the server, two special object proxies are constructed in the client, to represent the Root and Repository objects. These are the base through which all the other interactions are performed. Other object proxies may only be obtained by the return values of methods on existing objects, arguments passed in events from them, or retrieved as the value of properties on objects. Each object is an instance of some particular class. The class provides all of the typing information for that instance. Principly, that class defines a name, and the collection of methods, events, and properties that exist on instances of that class. Each class may also name other classes as parents; recursively merging the interface of all those named. Tangence concerns itself with the interface of and ways to interact with the objects in the server, and not with any ways in which the objects themselves are actually implemented. The class inheritance therefore only applies to the interface, and does not directly relate to any implementation behaviour the server might implement. 3.1. Methods Each object class may define named methods that clients can invoke on objects in the server. Each method has: + a name + argument types + a return type The arguments to a method are positional. The return is a single value (not a list of values, such as Perl could represent). Methods on objects in the server may be invoked by clients. Once a method is invoked by a client, the client must wait until it returns before it can send any other request to the server. 3.2 Events Each object class may define named events that objects may emit. Each method has: + a name + argument types Like methods, the arguments to an event are positional. Events do not have return types, as they are simple notifications from the server to the client, to inform them that some event happened. Clients are not automatically informed of every event on every object. Instead, the client must specifically register interest in specific events on specific objects. 3.3 Properties Each object class may define named properties that the object has. Each object in the class will have a value for the property. Each property has: + a name + a dimension - scalar, queue, array, hash or object set + a type + a boolean indicating if it is "smashed" Properties do not have arguments. A client can request the current value of a property on an object, or set a new value. It can also register an interest in the property, where the server will inform the client of changes to the value. Each property has a dimension; one of scalar, queue, array, hash, or object set. The behaviour of each type of property is: 3.3.1 Scalar Properties The property is a single atomic scalar. It is set atomically by the server, and may be queried. 3.3.2 Queue and Array Properties The property is a contiguous array of individual elements. Each element is indexed by a non-negative integer. The property type gives the type of each element in the array. These properties differ in the types of operations they can support. Queues do not support splice or move operations, arrays do. 3.3.3 Hash Properties The property is an association between string and values. Each element is uniquely indexed by a null-terminated string. The property type gives the type of each element in the hash. The elements do not have an inherent ordering and are indexed by unique strings. 3.3.4 Object Set Properties The property is an unordered collection of Tangence objects. Scalar properties have a single atomic value. If it changes, the client is informed of the entire new value, even if its type indicates it to be a list or dictionary type. For non-scalar properties, the value of each element in the collection is set individually by the server. Elements can be changed, added or removed. Changes to individual elements can be sent to the clients independently of the others. Certain properties may be deemed by the application to be important enough for all clients to be aware of all of the time (such as a name or other key item of information). These properties are called "smashed properties". When the server first sends a new object to a client, the object construction message will also contain initial values of these properties. The client will be automatically informed of any changes to these properties when they change, as if the client had specifically requested to be informed. When the object is sent to a new client, it is said to be "smashed"; the initial values of these automatic properties are called "smash values". [There are issues here that need resolving to move Tangence out from being Perl-specific into a more general-purpose layer - more on this in a later email]. Tangence-0.28/doc/04-serialisation.txt000444001750001750 4045514174566136 16507 0ustar00leoleo0000000000004. Serialisation ---------------- 4.1. Value serialisation The data serialisation format applies recursively down a data structure tree. Each node in structure is either a string, an object reference, or a list or dictionary of other values. The serialised bytes encode the tree structure recursively. Other types of entry also exist in the serialised stream, which carry metadata about the types, such as object classes and instances. The encoding of each node in the data structure consists of a type, a size, and the actual data payload. The type and size of a node are encoded in its leader byte (or bytes). The top three bits of the first byte determines the type: Type Bits Description DATA_NUMBER 0 0 0 t t t t t numeric where 'ttttt' gives the number subtype DATA_STRING 0 0 1 s s s s s string DATA_LIST 0 1 0 s s s s s list of values DATA_DICT 0 1 1 s s s s s dictionary of string->value DATA_OBJECT 1 0 0 s s s s s Tangence object reference DATA_RECORD 1 0 1 s s s s s structured record where 'sssss' gives the size DATA_META 1 1 1 n n n n n where 'nnnnn' gives the metadata type For numbers, the lower five bits encode the numeric type, which defines how many more bytes will be used Subtype Subtype bits Extra bytes Description DATANUM_BOOLFALSE 0 0 0 0 0 0 Boolean false DATANUM_BOOLTRUE 0 0 0 0 1 0 Boolean true DATANUM_UINT8 0 0 0 1 0 1 Unsigned 8bit DATANUM_SINT8 0 0 0 1 1 1 Signed 8bit DATANUM_UINT16 0 0 1 0 0 2 Unsigned 16bit DATANUM_SINT16 0 0 1 0 1 2 Signed 16bit DATANUM_UINT32 0 0 1 1 0 4 Unsigned 32bit DATANUM_SINT32 0 0 1 1 1 4 Signed 32bit DATANUM_UINT64 0 1 0 0 0 8 Unsigned 64bit DATANUM_SINT64 0 1 0 0 1 8 Signed 64bit DATANUM_FLOAT16 1 0 0 0 0 2 Floating 16bit DATANUM_FLOAT32 1 0 0 0 1 4 Floating 32bit DATANUM_FLOAT64 1 0 0 1 0 8 Floating 64bit All multi-byte integers are always stored in big-endian form. Floating-point values are stored in IEEE 754 form, as three bitfields containing sign, exponent and mantissa. The sign always has one bit, clear for positive, set for negative. The exponent and mantissa have the following sizes and bias. Subtype Exponent Bias Mantissa DATANUM_FLOAT16 5 bits +15 10 bits DATANUM_FLOAT32 8 bits +127 23 bits DATANUM_FLOAT64 11 bits +1023 52 bits Infinities and Not-a-Number values are represented by the exponent having its maximum allowed value. If the mantissa is zero this represents an infinity of the given sign, and if the mantissa is non-zero, it is a not-a-number value. For canonical identity, the non-zero mantissa should have only its top bit set, and the sign bit should be clear. Subtype Exponent Mantissa DATANUM_FLOAT16 31 0 Inf DATANUM_FLOAT16 31 1 << 9 NaN DATANUM_FLOAT32 255 0 Inf DATANUM_FLOAT32 255 1 << 22 NaN DATANUM_FLOAT64 1023 0 Inf DATANUM_FLOAT64 1023 1 << 51 NaN For string, list, dict and object types, the lower five bits give a number, 0 to 31, which helps encode the size. For items of size 30 or below, this size is encoded directly. Where the size is 31 or more, the number 31 is encoded, and the actual size follows this leading byte. For sizes 31 to 127, the next byte encodes it. For sizes 128 or above, the next 4 bytes encode it in big-endian format, with the top bit set. Sizes above 2^31 cannot be encoded. Following the leader are bytes encoding the data. The exact meaning of the size depends on the type of the node. For strings, the size gives the number of bytes in the string. These bytes then follow the leader. For lists, the size gives the number of elements in the list. Following the leader will be this number of data serialisations, one per list element. For dictionaries, this size gives the number of key/value pairs. Following the leader will be this number of key/value pairs. Each pair consists of a string for the key name, then a data serialisation for the value. For objects, the size gives the number of bytes in the object's ID number, followed by a big-endian encoding of the object's ID number. Currently, this will always be a 4 byte number. For structured records, the size gives the count of serialied data members for the record. Following the leader will be the ID number of the structure type as an int, followed by the given number of data members, in the order that the structure type declares. The field names are not serialised, as they can be inferred from the structure type's definition. Meta-data items may be embedded within a data stream in order to create the object classes and instances which it contains. These metadata items do not count towards the overall size of a collection value. Meta-data operations encode a subtype number, rather than a size, in the bottom five bits. Metadata type Bits Description DATAMETA_CONSTRUCT 1 1 1 0 0 0 0 1 Construct an object DATAMETA_CLASS 1 1 1 0 0 0 1 0 Create a new object class DATAMETA_STRUCT 1 1 1 0 0 0 1 1 Create a new record struct type Following each metadata item is an encoding of its arguments. DATAMETA_CONSTRUCT: Object ID: int Class ID: int Smash values: 0 or more bytes, encoded per type (in a list container) If the object class defines smash properties, the construct message will also contain the values for the smash properties. These will be sent in a list, one value per property, in the same order as the object class's schema defines the smash keys. Each will be encoded as per its declared type. DATAMETA_CLASS: Class name: string Class ID: int Class: struct of type Tangence.Class Smash keys: data encoded (list) The class definition itself will be encoded as a Tangence.Class structure, containing nested Tangence.Method, Tangence.Event and Tangence.Property elements. If the class declares any superclasses, these will be sent in other DATAMETA_CLASS metadata items before this one. The smash keys will be encoded as a possibly-empty list of strings. DATAMETA_STRUCT: Struct name: string Struct ID: int Field names: list of strings Field types: list of strings 4.2. Message Types Each of the messages defines the layout of its data payload. Some messages pass a fixed number of items, some have a variable number of items in the last position. For these messages, no explicit encoding of the size is given. Instead, the data payload area is packed with as many data encodings as are required. The receiver should use the size of the containing message to know when all the items have been unpacked. The following request types are defined. Any message may be responded to by MSG_ERROR in case of an error, so this response type is not listed. Some of these messages are sent from the client to the server (C->S), others are sent from the server to client (S->C) MSG_CALL (C->S) (0x01) INT object ID STRING method name data... arguments Responses: MSG_RESULT Calls the named method on the given object. MSG_SUBSCRIBE (C->S) (0x02) INT object ID STRING event name Responses: MSG_SUBSCRIBED Subscribes the client to be informed of the event on given object. MSG_UNSUBSCRIBE (C->S) (0x03) INT object ID STRING event name Responses: MSG_OK Cancels an event subscription. MSG_EVENT (S->C) (0x04) INT object ID STRING event name data... arguments Responses: MSG_OK Informs the client that the event has occured. MSG_GETPROP (C->S) (0x05) INT object ID STRING property name Responses: MSG_RESULT Requests the current value of the property MSG_SETPROP (C->S) (0x06) INT object ID STRING property name data new value Responses: MSG_OK Sets the new value of the property MSG_WATCH (C->S) (0x07) INT object ID STRING property name BOOL want initial? Responses: MSG_WATCHING Requests to be informed of changes to the property value. If the boolean 'want initial' value is true, the client will be sent an initial MSG_CHANGE message for the current value of the property. MSG_UNWATCH (C->S) (0x08) INT object ID STRING property name Responses: MSG_OK Cancels a request to watch a property MSG_UPDATE (S->C) (0x09) INT object ID STRING property name U8 change type data... change value Responses: MSG_OK Informs the client that the property value has now changed. The type of change is given by the change type argument, and defines the data layout in the value arguments. The exact meaning of the operation depends on the dimension of the property it acts on. For DIM_SCALAR: CHANGE_SET: data new value Sets the new value of the property. For DIM_HASH: CHANGE_SET: DICT new value Sets the new value of the property. CHANGE_ADD: STRING key data value Adds a new element to the hash. CHANGE_DEL: STRING key Deletes an element from the hash. For DIM_QUEUE: CHANGE_SET: LIST new value Sets the new value of the property. CHANGE_PUSH: data... additional values Appends the additional values to the end of the queue. CHANGE_SHIFT: INT number of elements Removes a number of leading elements from the beginning of the queue. For DIM_ARRAY: CHANGE_SET: LIST new value Sets the new value of the property. CHANGE_PUSH: data... additional values Appends the additional values to the end of the array. CHANGE_SHIFT: INT number of elements Removes a number of leading elements from the beginning of the array. CHANGE_SPLICE: INT start INT count data... new elements Replaces the given range of the array with the new elements given. The new list of values may be a different length to the replaced section - in this case, subsequent elements will be shifted up or down accordingly. CHANGE_MOVE: INT index INT delta Moves the item currently at the index forward a (signed) delta amount, such that its new index becomes index+delta. The items inbetween the old and new index will be moved up or down as appropriate. For DIM_OBJSET: CHANGE_SET: LIST objects Sets the new value for the property. Will be given a list of Tangence object references. CHANGE_ADD: OBJECT new object Adds the given object to the set CHANGE_DEL: STRING object ID Removes the object of the given ID from the set. MSG_DESTROY (S->C) (0x0a) INT object ID Responses: MSG_OK Informs the client that the object is due for destruction in the server. Upon receipt of this message the client should destroy any remaining references it has to the object. After it has sent the MSG_OK response, it will not be allowed to invoke any methods, subscribe to any events, nor interact with any properties on the object. Any existing event subscriptions or property watches will have been removed by the server before this message is sent. MSG_GETPROPELEM (C->S) (0x0b) INT object ID STRING property name INT|STRING element index or key Responses: MSG_RESULT Requests the current value of a single element in a queue or array (by element index), or hash (by key name). Cannot be applied to scalar or objset properties. MSG_WATCH_CUSR (C->S) (0x0c) INT object ID STRING property name INT from Responses: MSG_WATCHING_CUSR Similar to MSG_WATCH, requests to be informed of changes to the property value, which must be a queue property. Creates a new cursor for the property, beginning at the first index (if from == 1) or the last (if from == 2). MSG_CUSR_NEXT (C->S) (0x0d) INT cursor ID INT direction INT count Responses: MSG_CUSR_RESULT Requests the next few items from a property cursor. It will yield a MSG_RESULT message containing up to the given number of items, by moving forwards (if direction == 1) or backwards (if direction == 2). If the cursor is already at the edge of the queue then the MSG_RESULT will contain no extra items. MSG_CUSR_DESTROY (C->S) (0x0e) INT cursor ID Informs the server that the client has finished using the cursor, and it can release any resources attached to it. MSG_GETROOT (C->S) (0x40) data identity Responses: MSG_RESULT Initial message to be sent by the client to obtain the root object. The identity may be used to identify this particular client, as part of its login procedure. The result will contain a single object reference, being the root object. MSG_GETREGISTRY (C->S) (0x41) [no arguments] Responses: MSG_RESULT Requests the registry object from the server. The result will contain a single object reference, being the registry object. MSG_INIT (C->S) (0x7f) INT major version INT maximal minor version INT minimal minor version Responses: MSG_INITED Requests the start of the Tangence stream. This must be the first message sent by the client. If the server is unwilling to provide a suitable version it can return MSG_ERROR. Otherwise, the accepted minor is returned in the MSG_INITED message. The version specified by this document is major 0, minor 4. The following responses may be sent to a request: MSG_OK (0x80) [no arguments] A simple OK message, informing the requester that the operation was successful, an no error occured. MSG_ERROR (0x81) STRING error message An error occured; the text of the message is included. MSG_RESULT (0x82) data... values Contains the return value from a method call, a property value, or the initial root or registry object. MSG_SUBSCRIBED (0x83) [no arguments] Informs the client that a MSG_SUBSCRIBE was successful. MSG_WATCHING (0x84) [no arguments] Informs the client that a MSG_WATCH was successful. MSG_WATCHING_CUSR (0x85) INT cursor ID INT first index (inclusive) INT last index (inclusive) Informs the client that a MSG_WATCH_CUSR was successful, and returns the new cursor ID and the first and last indices inclusive of the queue it will iterate over. ((The reason for using first and last indices inclusively, rather than yielding the total size of the queue, is that this makes it easier to support iterating over hashes in a future version)) MSG_CUSR_RESULT (0x86) INT first item index data... values Contains the return value from a MSG_CUSR_NEXT call. Gives the index of the first item in the returned result, and the requested items. There may fewer items than requested, if the edge of the property value was reached. MSG_INITED (0xff) INT major version INT minor version Informs the client that the initial MSG_INIT was successful, and what minor version was accepted. 4.3 Built-in Structure Types The following structure types are built-in, with the given structure ID numbers. They can be assumed pre-knowledge by both ends of the stream and do not need serialising by DATAMETA_STRUCT records. 4.3.1 Tangence.Class Structure ID: 1 Fields: methods : dict(any) events : dict(any) properties : dict(any) superclasses : list(str) 4.3.2 Tangence.Method Structure ID: 2 Fields: arguments : list(str) returns : str 4.3.3 Tangence.Event Structure ID: 3 Fields: arguments : list(str) 4.3.4 Tangence.Property Structure ID: 4 Fields: dimension : int type : str smashed : bool Tangence-0.28/doc/05-wireprotocol.txt000444001750001750 431314174566136 16343 0ustar00leoleo0000000000005. Wire Protocol ---------------- The wire protocol used by Tangence operates over a reliable stream. This stream may be provided by a TCP socket, UNIX local socket, or even the STDIN/STDOUT pipe pair of an SSH connection. The following message descriptions all use the symbolic constant names from the Tangence::Constants perl module, to be more readable. 5.1. Messages At its lowest level, the wire protocol consists of a pair of endpoints to the stream, each sending and receiving messages to its peer. The protocol at this level is symmetric between the client and the server. It consists of messages that are either reqests or responses. An endpoint sends a request, which the peer must then respond to. Each request has exactly one response. The requests and responses are paired sequentially in a pipeline fashion. The two endpoints are distinct from each other, in that there is no requirement for a peer to respond to an outstanding request it has received before sending a new request of its own. There is also no requirement to wait on the response to a request it has sent, before sending another. The basic message format is a binary exchange of messages in the following format: Code: 1 byte integer Length: 4 bytes integer, big-endian Payload: n bytes The code is a single byte which defines the message type. The collection of message types is given below. The length is a big-endian 4 byte integer which gives the size of the message payload, excluding this header. Thus, the length of the entire message will always be 5 bytes more. The data payload of the message is encoded in the data serialisation scheme given below. Each argument to the message is encoded as a single serialisation item. For message types with a variable number of arguments, the length of the message itself defines the number of arguments given. The stream protocol is designed to be used in situations where the CPU power of each endpoint is high, but the connection in between may have high latency, or low bandwidth. It is therefore optimised in favour of roundtrips and byte count overhead, at the expense of processing power needed to encode or decode it. One consequence here is that no attempt is made to align multi-byte values. Tangence-0.28/lib000755001750001750 014174566136 12473 5ustar00leoleo000000000000Tangence-0.28/lib/Tangence.pm000444001750001750 146514174566136 14720 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk package Tangence 0.28; use v5.26; use warnings; # This package contains no code other than a declaration of the version. # It is provided simply to keep CPAN happy: # cpan -i Tangence =head1 NAME C - attribute-oriented server/client object remoting framework =head1 DESCRIPTION Like CORBA only much smaller, lighter, and with heavy emphasis on attributes of remoted objects, including notifications of modification and atomic update operations. =head1 TODO Docs. Other languages. Static metadata. Other metadata backend generation - L? =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence000755001750001750 014174566136 14217 5ustar00leoleo000000000000Tangence-0.28/lib/Tangence/Class.pm000444001750001750 743414174566136 15767 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Class 0.28; class Tangence::Class isa Tangence::Meta::Class; use Tangence::Constants; use Tangence::Property; use Tangence::Meta::Method; use Tangence::Meta::Event; use Tangence::Meta::Argument; use Carp; use Sub::Util 1.40 qw( set_subname ); our %CLASSES; # cache one per class, keyed by _Tangence_ class name sub make ( $class, %args ) { my $name = $args{name}; return $CLASSES{$name} //= $class->new( %args ); } sub _new_type ( $sig ) { return Tangence::Type->make_from_sig( $sig ); } sub declare ( $class, $perlname, %args ) { ( my $name = $perlname ) =~ s{::}{.}g; if( exists $CLASSES{$name} ) { croak "Cannot re-declare $name"; } my $self = $class->make( name => $name ); my %methods; foreach ( keys %{ $args{methods} } ) { my %params = %{ $args{methods}{$_} }; $methods{$_} = Tangence::Meta::Method->new( class => $self, name => $_, arguments => [ map { Tangence::Meta::Argument->new( name => $_->[0], type => _new_type( $_->[1] ) ) } @{ delete $params{args} } ], ret => _new_type( delete $params{ret} ), %params, ); } my %events; foreach ( keys %{ $args{events} } ) { my %params = %{ $args{events}{$_} }; $events{$_} = Tangence::Meta::Event->new( class => $self, name => $_, arguments => [ map { Tangence::Meta::Argument->new( name => $_->[0], type => _new_type( $_->[1] ) ) } @{ delete $params{args} } ], %params, ); } my %properties; foreach ( keys %{ $args{props} } ) { my %params = %{ $args{props}{$_} }; $properties{$_} = Tangence::Property->new( class => $self, name => $_, dimension => ( delete $params{dim} ) || DIM_SCALAR, type => _new_type( delete $params{type} ), %params, ); } my @superclasses; foreach ( @{ $args{superclasses} } ) { push @superclasses, Tangence::Class->for_perlname( $_ ); } $self->define( methods => \%methods, events => \%events, properties => \%properties, superclasses => \@superclasses, ); } method define { $self->SUPER::define( @_ ); my $class = $self->perlname; my %subs; foreach my $prop ( values %{ $self->direct_properties } ) { $prop->build_accessor( \%subs ); } no strict 'refs'; foreach my $name ( keys %subs ) { next if defined &{"${class}::${name}"}; *{"${class}::${name}"} = set_subname "${class}::${name}" => $subs{$name}; } } sub for_name ( $class, $name ) { return $CLASSES{$name} // croak "Unknown Tangence::Class for '$name'"; } sub for_perlname ( $class, $perlname ) { ( my $name = $perlname ) =~ s{::}{.}g; return $CLASSES{$name} // croak "Unknown Tangence::Class for '$perlname'"; } sub superclasses { my $self = shift; my @supers = $self->SUPER::superclasses; if( !@supers and $self->perlname ne "Tangence::Object" ) { @supers = Tangence::Class->for_perlname( "Tangence::Object" ); } return @supers; } method method ( $name ) { return $self->methods->{$name}; } method event ( $name ) { return $self->events->{$name}; } method property ( $name ) { return $self->properties->{$name}; } has $smashkeys; method smashkeys { return $smashkeys //= do { my %smash; $smash{$_->name} = 1 for grep { $_->smashed } values %{ $self->properties }; $Tangence::Message::SORT_HASH_KEYS ? [ sort keys %smash ] : [ keys %smash ]; }; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Client.pm000444001750001750 2111714174566136 16152 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk package Tangence::Client 0.28; use v5.26; use warnings; use experimental 'signatures'; use base qw( Tangence::Stream ); use Carp; use Tangence::Constants; use Tangence::Types; use Tangence::ObjectProxy; use Future 0.36; # ->retain use List::Util qw( max ); use constant VERSION_MINOR_MIN => 3; =head1 NAME C - mixin class for building a C client =head1 SYNOPSIS This class is a mixin, it cannot be directly constructed package Example::Client; use base qw( Base::Client Tangence::Client ); sub connect { my $self = shift; $self->SUPER::connect( @_ ); $self->tangence_connected; wait_for { defined $self->rootobj }; } sub tangence_write { my $self = shift; $self->write( $_[0] ); } sub on_read { my $self = shift; $self->tangence_readfrom( $_[0] ); } package main; my $client = Example::Client->new; $client->connect( "server.location.here" ); my $rootobj = $client->rootobj; =head1 DESCRIPTION This module provides mixin to implement a C client connection. It should be mixed in to an object used to represent a single connection to a server. It provides a central location in the client to store object proxies, including to the root object and the registry, and coordinates passing messages between the server and the object proxies it contains. This is a subclass of L which provides implementations of the required C methods. A class mixing in C must still provide the C method required for sending data to the server. For an example of a class that uses this mixin, see L. =cut =head1 PROVIDED METHODS The following methods are provided by this mixin. =cut # Accessors for Tangence::Message decoupling sub objectproxies { shift->{objectproxies} ||= {} } =head2 rootobj $rootobj = $client->rootobj Returns a L to the server's root object =cut sub rootobj { my $self = shift; $self->{rootobj} = shift if @_; return $self->{rootobj}; } =head2 registry $registry = $client->registry Returns a L to the server's object registry if one has been received, or C if not. This method is now deprecated in favour of L. Additionally note that currently the client will attempt to request the registry at connection time, but a later version of this module will stop doing that, so users who need access to it should call C. =cut sub registry { my $self = shift; $self->{registry} = shift if @_; return $self->{registry}; } =head2 get_registry $registry = $client->get_registry->get Returns a L that will yield a L to the server's registry object. Note that not all servers may permit access to the registry. =cut sub get_registry { my $self = shift; $self->request( request => Tangence::Message->new( $self, MSG_GETREGISTRY ), )->then( sub { my ( $message ) = @_; my $code = $message->code; $code == MSG_RESULT or return Future->fail( "Cannot get registry - code $code", tangence => $message ); $self->registry( TYPE_OBJ->unpack_value( $message ) ); return Future->done( $self->registry ); }); } sub on_error { my $self = shift; $self->{on_error} = shift if @_; return $self->{on_error}; } =head2 tangence_connected $client->tangence_connected( %args ) Once the base connection to the server has been established, this method should be called to perform the initial work of requesting the root object and the registry. It takes the following named arguments: =over 8 =item do_init => BOOL Ignored. Maintained for compatibility with previous version that allowed this to be disabled. =item on_root => CODE Optional callback to be invoked once the root object has been returned. It will be passed a L to the root object. $on_root->( $rootobj ) =item on_registry => CODE Optional callback to be invoked once the registry has been returned. It will be passed a L to the registry. $on_registry->( $registry ) Note that in the case that the server does not permit access to the registry or an error occurs while requesting it, this is invoked with an empty list. $on_registry->() =item version_minor_min => INT Optional minimum minor version to negotiate with the server. This can be used to require a higher minimum version than the client module itself supports, in case the application requires features in a newer version than that. =back =cut sub tangence_connected ( $self, %args ) { my $version_minor_min = max( VERSION_MINOR_MIN, $args{version_minor_min} || 0 ); $self->request( request => Tangence::Message->new( $self, MSG_INIT ) ->pack_int( VERSION_MAJOR ) ->pack_int( VERSION_MINOR ) ->pack_int( $version_minor_min ), on_response => sub { my ( $message ) = @_; my $code = $message->code; if( $code == MSG_INITED ) { my $major = $message->unpack_int(); my $minor = $message->unpack_int(); $self->minor_version( $minor ); $self->tangence_initialised( %args ); } elsif( $code == MSG_ERROR ) { my $msg = $message->unpack_str(); print STDERR "Cannot initialise stream - error $msg"; } else { print STDERR "Cannot initialise stream - code $code\n"; } }, ); } sub tangence_initialised ( $self, %args ) { my $request = Tangence::Message->new( $self, MSG_GETROOT ); TYPE_ANY->pack_value( $request, $self->identity ); $self->request( request => $request, on_response => sub { my ( $message ) = @_; my $code = $message->code; if( $code == MSG_RESULT ) { $self->rootobj( TYPE_OBJ->unpack_value( $message ) ); $args{on_root}->( $self->rootobj ) if $args{on_root}; } elsif( $code == MSG_ERROR ) { my $msg = $message->unpack_str(); print STDERR "Cannot get root object - error $msg"; } else { print STDERR "Cannot get root object - code $code\n"; } } ); $self->get_registry->then( sub { my ( $registry ) = @_; $args{on_registry}->( $registry ) if $args{on_registry}; }, sub { $args{on_registry}->() if $args{on_registry}; } )->retain; } sub handle_request_EVENT ( $self, $token, $message ) { my $objid = $message->unpack_int(); $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); if( my $obj = $self->objectproxies->{$objid} ) { $obj->handle_request_EVENT( $message ); } } sub handle_request_UPDATE ( $self, $token, $message ) { my $objid = $message->unpack_int(); $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); if( my $obj = $self->objectproxies->{$objid} ) { $obj->handle_request_UPDATE( $message ); } } sub handle_request_DESTROY ( $self, $token, $message ) { my $objid = $message->unpack_int(); if( my $obj = $self->objectproxies->{$objid} ) { $obj->destroy; delete $self->objectproxies->{$objid}; } $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); } sub get_by_id ( $self, $id ) { return $self->objectproxies->{$id} if exists $self->objectproxies->{$id}; croak "Have no proxy of object id $id"; } sub make_proxy ( $self, $id, $classname, $smashdata ) { if( exists $self->objectproxies->{$id} ) { croak "Already have an object id $id"; } my $class; if( defined $classname ) { $class = $self->peer_hasclass->{$classname}->[0]; defined $class or croak "Cannot construct a proxy for class $classname as no meta exists"; } my $obj = $self->objectproxies->{$id} = Tangence::ObjectProxy->new( client => $self, id => $id, class => $class, on_error => $self->on_error, ); $obj->grab( $smashdata ) if defined $smashdata; return $obj; } =head1 SUBCLASSING METHODS These methods are intended for implementation classes to override. =cut =head2 new_future $f = $client->new_future Returns a new L instance for basing asynchronous operations on. =cut sub new_future { return Future->new; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Constants.pm000444001750001750 1020014174566136 16677 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2016 -- leonerd@leonerd.org.uk package Tangence::Constants 0.28; use v5.26; use warnings; use Exporter 'import'; our @EXPORT = qw( MSG_CALL MSG_SUBSCRIBE MSG_UNSUBSCRIBE MSG_EVENT MSG_GETPROP MSG_SETPROP MSG_WATCH MSG_UNWATCH MSG_UPDATE MSG_DESTROY MSG_GETPROPELEM MSG_WATCH_CUSR MSG_CUSR_NEXT MSG_CUSR_DESTROY MSG_GETROOT MSG_GETREGISTRY MSG_INIT MSG_OK MSG_ERROR MSG_RESULT MSG_SUBSCRIBED MSG_WATCHING MSG_WATCHING_CUSR MSG_CUSR_RESULT MSG_INITED DIM_SCALAR DIM_HASH DIM_QUEUE DIM_ARRAY DIM_OBJSET DIMNAMES CHANGE_SET CHANGE_ADD CHANGE_DEL CHANGE_PUSH CHANGE_SHIFT CHANGE_SPLICE CHANGE_MOVE CHANGETYPES CUSR_FIRST CUSR_LAST CUSR_FWD CUSR_BACK DATA_NUMBER DATA_STRING DATA_LIST DATA_DICT DATA_OBJECT DATA_RECORD DATA_META DATANUM_BOOLFALSE DATANUM_BOOLTRUE DATANUM_UINT8 DATANUM_SINT8 DATANUM_UINT16 DATANUM_SINT16 DATANUM_UINT32 DATANUM_SINT32 DATANUM_UINT64 DATANUM_SINT64 DATANUM_FLOAT16 DATANUM_FLOAT32 DATANUM_FLOAT64 DATAMETA_CONSTRUCT DATAMETA_CLASS DATAMETA_STRUCT VERSION_MAJOR VERSION_MINOR ); # Message types # Requests use constant MSG_CALL => 0x01; use constant MSG_SUBSCRIBE => 0x02; use constant MSG_UNSUBSCRIBE => 0x03; use constant MSG_EVENT => 0x04; use constant MSG_GETPROP => 0x05; use constant MSG_SETPROP => 0x06; use constant MSG_WATCH => 0x07; use constant MSG_UNWATCH => 0x08; use constant MSG_UPDATE => 0x09; use constant MSG_DESTROY => 0x0a; use constant MSG_GETPROPELEM => 0x0b; use constant MSG_WATCH_CUSR => 0x0c; use constant MSG_CUSR_NEXT => 0x0d; use constant MSG_CUSR_DESTROY => 0x0e; use constant MSG_GETROOT => 0x40; use constant MSG_GETREGISTRY => 0x41; use constant MSG_INIT => 0x7f; # Responses use constant MSG_OK => 0x80; use constant MSG_ERROR => 0x81; use constant MSG_RESULT => 0x82; use constant MSG_SUBSCRIBED => 0x83; use constant MSG_WATCHING => 0x84; use constant MSG_WATCHING_CUSR => 0x85; use constant MSG_CUSR_RESULT => 0x86; use constant MSG_INITED => 0xff; # Property dimensions use constant DIM_SCALAR => 1; use constant DIM_HASH => 2; use constant DIM_QUEUE => 3; use constant DIM_ARRAY => 4; use constant DIM_OBJSET => 5; use constant DIMNAMES => [ undef, "scalar", "hash", "queue", "array", "objset", ]; # Property change types use constant CHANGE_SET => 1; use constant CHANGE_ADD => 2; use constant CHANGE_DEL => 3; use constant CHANGE_PUSH => 4; use constant CHANGE_SHIFT => 5; use constant CHANGE_SPLICE => 6; use constant CHANGE_MOVE => 7; use constant CHANGETYPES => { DIM_SCALAR() => [qw( on_set )], DIM_HASH() => [qw( on_set on_add on_del )], DIM_QUEUE() => [qw( on_set on_push on_shift )], DIM_ARRAY() => [qw( on_set on_push on_shift on_splice on_move )], DIM_OBJSET() => [qw( on_set on_add on_del )], }; # Cursor messages use constant CUSR_FIRST => 1; use constant CUSR_LAST => 2; use constant CUSR_FWD => 1; use constant CUSR_BACK => 2; # Stream data types use constant DATA_NUMBER => 0; use constant DATANUM_BOOLFALSE => 0; use constant DATANUM_BOOLTRUE => 1; use constant DATANUM_UINT8 => 2; use constant DATANUM_SINT8 => 3; use constant DATANUM_UINT16 => 4; use constant DATANUM_SINT16 => 5; use constant DATANUM_UINT32 => 6; use constant DATANUM_SINT32 => 7; use constant DATANUM_UINT64 => 8; use constant DATANUM_SINT64 => 9; use constant DATANUM_FLOAT16 => 16; use constant DATANUM_FLOAT32 => 17; use constant DATANUM_FLOAT64 => 18; use constant DATA_STRING => 1; use constant DATA_LIST => 2; use constant DATA_DICT => 3; use constant DATA_OBJECT => 4; use constant DATA_RECORD => 5; use constant DATA_META => 7; use constant DATAMETA_CONSTRUCT => 1; use constant DATAMETA_CLASS => 2; use constant DATAMETA_STRUCT => 3; use constant VERSION_MAJOR => 0; use constant VERSION_MINOR => 4; =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Message.pm000444001750001750 2706014174566136 16323 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Message 0.28; class Tangence::Message; use Carp; use Tangence::Constants; use Tangence::Class; use Tangence::Meta::Method; use Tangence::Meta::Event; use Tangence::Property; use Tangence::Meta::Argument; use Tangence::Struct; use Tangence::Types; use Tangence::Object; use List::Util 1.29 qw( pairmap ); use Scalar::Util qw( weaken blessed ); # Normally we don't care about hash key order. But, when writing test scripts # that will assert on the serialisation bytes, we do. Setting this to some # true value will sort keys first our $SORT_HASH_KEYS = 0; has $_stream :param :reader; has $_code :param :reader; has $_payload :param :reader; sub BUILDARGS ( $class, $stream, $code, $payload = "" ) { return ( stream => $stream, code => $code, payload => $payload ); } method _pack_leader ( $type, $num ) { if( $num < 0x1f ) { $_payload .= pack( "C", ( $type << 5 ) | $num ); } elsif( $num < 0x80 ) { $_payload .= pack( "CC", ( $type << 5 ) | 0x1f, $num ); } else { $_payload .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 ); } } method _peek_leader_type { while(1) { length $_payload or croak "Ran out of bytes before finding a leader"; my ( $typenum ) = unpack( "C", $_payload ); my $type = $typenum >> 5; return $type unless $type == DATA_META; substr( $_payload, 0, 1, "" ); my $num = $typenum & 0x1f; if( $num == DATAMETA_CONSTRUCT ) { $self->unpackmeta_construct; } elsif( $num == DATAMETA_CLASS ) { $self->unpackmeta_class; } elsif( $num == DATAMETA_STRUCT ) { $self->unpackmeta_struct; } else { die sprintf("TODO: Data stream meta-operation 0x%02x", $num); } } } method _unpack_leader ( $peek = 0 ) { my $type = $self->_peek_leader_type; my ( $typenum ) = unpack( "C", $_payload ); my $num = $typenum & 0x1f; my $len = 1; if( $num == 0x1f ) { ( $num ) = unpack( "x C", $_payload ); if( $num < 0x80 ) { $len = 2; } else { ( $num ) = unpack( "x N", $_payload ); $num &= 0x7fffffff; $len = 5; } } substr( $_payload, 0, $len ) = "" if !$peek; return $type, $num; } method _pack ( $s ) { $_payload .= $s; } method _unpack ( $num ) { length $_payload >= $num or croak "Can't pull $num bytes as there aren't enough"; return substr( $_payload, 0, $num, "" ); } method pack_bool ( $d ) { TYPE_BOOL->pack_value( $self, $d ); return $self; } method unpack_bool { return TYPE_BOOL->unpack_value( $self ); } method pack_int ( $d ) { TYPE_INT->pack_value( $self, $d ); return $self; } method unpack_int { return TYPE_INT->unpack_value( $self ); } method pack_str ( $d ) { TYPE_STR->pack_value( $self, $d ); return $self; } method unpack_str { return TYPE_STR->unpack_value( $self ); } method pack_record ( $rec, $struct = undef ) { $struct ||= eval { Tangence::Struct->for_perlname( ref $rec ) } or croak "No struct for " . ref $rec; $self->packmeta_struct( $struct ) unless $_stream->peer_hasstruct->{$struct->perlname}; my @fields = $struct->fields; $self->_pack_leader( DATA_RECORD, scalar @fields ); $self->pack_int( $_stream->peer_hasstruct->{$struct->perlname}->[1] ); foreach my $field ( @fields ) { my $fieldname = $field->name; $field->type->pack_value( $self, $rec->$fieldname ); } return $self; } method unpack_record ( $struct = undef ) { my ( $type, $num ) = $self->_unpack_leader(); $type == DATA_RECORD or croak "Expected to unpack a record but did not find one"; my $structid = $self->unpack_int(); my $got_struct = $_stream->message_state->{id2struct}{$structid}; if( !$struct ) { $struct = $got_struct; } else { $struct->name eq $got_struct->name or croak "Expected to unpack a ".$struct->name." but found ".$got_struct->name; } $num == $struct->fields or croak "Expected ".$struct->name." to unpack from ".(scalar $struct->fields)." fields"; my %values; foreach my $field ( $struct->fields ) { $values{$field->name} = $field->type->unpack_value( $self ); } return $struct->perlname->new( %values ); } method packmeta_construct ( $obj ) { my $class = $obj->class; my $id = $obj->id; $self->packmeta_class( $class ) unless $_stream->peer_hasclass->{$class->perlname}; my $smashkeys = $class->smashkeys; $self->_pack_leader( DATA_META, DATAMETA_CONSTRUCT ); $self->pack_int( $id ); $self->pack_int( $_stream->peer_hasclass->{$class->perlname}->[2] ); if( @$smashkeys ) { my $smashdata = $obj->smash( $smashkeys ); for my $prop ( @$smashkeys ) { $_stream->_install_watch( $obj, $prop ); } if( $_stream->_ver_can_typed_smash ) { $self->_pack_leader( DATA_LIST, scalar @$smashkeys ); foreach my $prop ( @$smashkeys ) { $class->property( $prop )->overall_type->pack_value( $self, $smashdata->{$prop} ); } } else { TYPE_LIST_ANY->pack_value( $self, [ map { $smashdata->{$_} } @$smashkeys ] ); } } else { $self->_pack_leader( DATA_LIST, 0 ); } weaken( my $weakstream = $_stream ); $_stream->peer_hasobj->{$id} = $obj->subscribe_event( destroy => sub { $weakstream->object_destroyed( @_ ) if $weakstream }, ); } method unpackmeta_construct { my $id = $self->unpack_int(); my $classid = $self->unpack_int(); my $class_perlname = $_stream->message_state->{id2class}{$classid}; my ( $class, $smashkeys ) = @{ $_stream->peer_hasclass->{$class_perlname} }; my $smasharr; if( $_stream->_ver_can_typed_smash ) { my ( $type, $num ) = $self->_unpack_leader; $type == DATA_LIST or croak "Expected to unpack a LIST of smashed data"; $num == @$smashkeys or croak "Expected to unpack a LIST of " . ( scalar @$smashkeys ) . " elements"; foreach my $prop ( @$smashkeys ) { push @$smasharr, $class->property( $prop )->overall_type->unpack_value( $self ); } } else { $smasharr = TYPE_LIST_ANY->unpack_value( $self ); } my $smashdata; $smashdata->{$smashkeys->[$_]} = $smasharr->[$_] for 0 .. $#$smasharr; $_stream->make_proxy( $id, $class_perlname, $smashdata ); } method packmeta_class ( $class ) { my @superclasses = grep { $_->name ne "Tangence.Object" } $class->direct_superclasses; $_stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses; $self->_pack_leader( DATA_META, DATAMETA_CLASS ); my $smashkeys = $class->smashkeys; my $classid = ++$_stream->message_state->{next_classid}; $self->pack_str( $class->name ); $self->pack_int( $classid ); my $classrec = Tangence::Struct::Class->new( methods => { pairmap { $a => Tangence::Struct::Method->new( arguments => [ map { $_->type->sig } $b->arguments ], returns => ( $b->ret ? $b->ret->sig : "" ), ) } %{ $class->direct_methods } }, events => { pairmap { $a => Tangence::Struct::Event->new( arguments => [ map { $_->type->sig } $b->arguments ], ) } %{ $class->direct_events } }, properties => { pairmap { $a => Tangence::Struct::Property->new( dimension => $b->dimension, type => $b->type->sig, smashed => $b->smashed, ) } %{ $class->direct_properties } }, superclasses => [ map { $_->name } @superclasses ], ); $self->pack_record( $classrec ); TYPE_LIST_STR->pack_value( $self, $smashkeys ); $_stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ]; } method unpackmeta_class { my $name = $self->unpack_str(); my $classid = $self->unpack_int(); my $classrec = $self->unpack_record(); my $class = Tangence::Meta::Class->new( name => $name ); $class->define( methods => { pairmap { $a => Tangence::Meta::Method->new( class => $class, name => $a, ret => $b->returns ? Tangence::Type->make_from_sig( $b->returns ) : undef, arguments => [ map { Tangence::Meta::Argument->new( type => Tangence::Type->make_from_sig( $_ ), ) } @{ $b->arguments } ], ) } %{ $classrec->methods } }, events => { pairmap { $a => Tangence::Meta::Event->new( class => $class, name => $a, arguments => [ map { Tangence::Meta::Argument->new( type => Tangence::Type->make_from_sig( $_ ), ) } @{ $b->arguments } ], ) } %{ $classrec->events } }, properties => { pairmap { # Need to use non-Meta:: Property so it can generate overall type # using Tangence::Type instead of Tangence::Meta::Type $a => Tangence::Property->new( class => $class, name => $a, dimension => $b->dimension, type => Tangence::Type->make_from_sig( $b->type ), smashed => $b->smashed, ) } %{ $classrec->properties } }, superclasses => do { my @superclasses = map { ( my $perlname = $_ ) =~ s/\./::/g; $_stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname"; } @{ $classrec->superclasses }; @superclasses ? \@superclasses : [ Tangence::Class->for_name( "Tangence.Object" ) ] }, ); my $perlname = $class->perlname; my $smashkeys = TYPE_LIST_STR->unpack_value( $self ); $_stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ]; if( defined $classid ) { $_stream->message_state->{id2class}{$classid} = $perlname; } } method packmeta_struct ( $struct ) { $self->_pack_leader( DATA_META, DATAMETA_STRUCT ); my @fields = $struct->fields; my $structid = ++$_stream->message_state->{next_structid}; $self->pack_str( $struct->name ); $self->pack_int( $structid ); TYPE_LIST_STR->pack_value( $self, [ map { $_->name } @fields ] ); TYPE_LIST_STR->pack_value( $self, [ map { $_->type->sig } @fields ] ); $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; } method unpackmeta_struct { my $name = $self->unpack_str(); my $structid = $self->unpack_int(); my $names = TYPE_LIST_STR->unpack_value( $self ); my $types = TYPE_LIST_STR->unpack_value( $self ); my $struct = Tangence::Struct->make( name => $name ); if( !$struct->defined ) { $struct->define( fields => [ map { $names->[$_] => $types->[$_] } 0 .. $#$names ] ); } $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; $_stream->message_state->{id2struct}{$structid} = $struct; } method pack_all_sametype ( $type, @d ) { $type->pack_value( $self, $_ ) for @d; return $self; } method unpack_all_sametype ( $type ) { my @data; push @data, $type->unpack_value( $self ) while length $_payload; return @data; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Object.pm000444001750001750 3416714174566136 16153 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk package Tangence::Object 0.28; use v5.26; use warnings; use experimental 'signatures'; use Carp; use Syntax::Keyword::Match; use Tangence::Constants; use Tangence::Types; use Tangence::Class; Tangence::Class->declare( __PACKAGE__, events => { destroy => { args => [], }, }, ); =head1 NAME C - base class for accessible objects in a C server =head1 DESCRIPTION This class acts as a base class for the accessible objects in a L server. All the objects actually created and made accessible to clients will be subclasses of this one, including internally-created objects such as L. These objects are not directly constructed by calling the C class method; instead the C should be used to construct one. =cut sub new ( $class, %args ) { defined( my $id = delete $args{id} ) or croak "Need a id"; my $registry = delete $args{registry} or croak "Need a registry"; my $self = bless { id => $id, registry => $registry, meta => $args{meta} || Tangence::Class->for_perlname( $class ), event_subs => {}, # {$event} => [ @cbs ] properties => {}, # {$prop} => T:P::Instance struct }, $class; my $properties = $self->class->properties; foreach my $prop ( keys %$properties ) { my $meth = "new_prop_$prop"; $self->$meth(); } return $self; } =head1 METHODS =cut =head2 destroy $obj->destroy Requests that the object destroy itself, informing all clients that are aware of it. Once they all report that they have dropped the object, the object is deconstructed for real. Not to be confused with Perl's own C method. =cut sub destroy ( $self, %args ) { $self->{destroying} = 1; my $outstanding = 1; my $on_destroyed = $args{on_destroyed}; my $incsub = sub { $outstanding++ }; my $decsub = sub { --$outstanding and return; $self->_destroy_really; $on_destroyed->() if $on_destroyed; }; foreach my $cb ( @{ $self->{event_subs}->{destroy} } ) { $cb->( $self, $incsub, $decsub ); } $decsub->(); } sub _destroy_really { my $self = shift; $self->registry->destroy_object( $self ); undef %$self; # Now I am dead $self->{destroyed} = 1; } =head2 id $id = $obj->id Returns the object's C ID number =cut sub id { my $self = shift; return $self->{id}; } =head2 describe $description = $obj->describe Returns a textual description of the object, for internal debugging purposes. Subclasses are encouraged to override this method to return something more descriptive within their domain of interest =cut sub describe { my $self = shift; return ref $self; } =head2 registry $registry = $obj->registry Returns the L that constructed this object. =cut sub registry { my $self = shift; return $self->{registry}; } sub smash ( $self, $smashkeys ) { return undef unless $smashkeys and @$smashkeys; my @keys; if( ref $smashkeys eq "HASH" ) { @keys = keys %$smashkeys; } else { @keys = @$smashkeys; } return { map { my $m = "get_prop_$_"; $_ => $self->$m() } @keys }; } =head2 class $class = $obj->class Returns the L object representing the class of this object. =cut sub class { my $self = shift; return ref $self ? $self->{meta} : Tangence::Class->for_perlname( $self ); } =head2 can_method $method = $obj->can_method( $name ) Returns the L object representing the named method, or C if no such method exists. =cut sub can_method { my $self = shift; return $self->class->method( @_ ); } =head2 can_event $event = $obj->can_event( $name ) Returns the L object representing the named event, or C if no such event exists. =cut sub can_event { my $self = shift; return $self->class->event( @_ ); } =head2 can_property $property = $obj->can_property( $name ) Returns the L object representing the named property, or C if no such property exists. =cut sub can_property { my $self = shift; return $self->class->property( @_ ); } sub smashkeys { my $self = shift; return $self->class->smashkeys; } =head2 fire_event $obj->fire_event( $event, @args ) Fires the named event on the object. Each event subscription function will be invoked with the given arguments. =cut sub fire_event ( $self, $event, @args ) { $event eq "destroy" and croak "$self cannot fire destroy event directly"; $self->can_event( $event ) or croak "$self has no event $event"; my $sublist = $self->{event_subs}->{$event} or return; foreach my $cb ( @$sublist ) { $cb->( $self, @args ); } } =head2 subscribe_event $id = $obj->subscribe_event( $event, $callback ) Subscribes an event-handling callback CODE ref to the named event. When the event is fired by C this callback will be invoked, being passed the object reference and the event's arguments. $callback->( $obj, @args ) Returns an opaque ID value that can be used to remove this subscription by calling C. =cut sub subscribe_event ( $self, $event, $callback ) { $self->can_event( $event ) or croak "$self has no event $event"; my $sublist = ( $self->{event_subs}->{$event} ||= [] ); push @$sublist, $callback; my $ref = \@{$sublist}[$#$sublist]; # reference to last element return $ref + 0; # force numeric context } =head2 unsubscribe_event $obj->unsubscribe_event( $event, $id ) Removes an event-handling callback previously registered with C. =cut sub unsubscribe_event ( $self, $event, $id ) { my $sublist = $self->{event_subs}->{$event} or return; my $index; for( $index = 0; $index < @$sublist; $index++ ) { last if \@{$sublist}[$index] + 0 == $id; } splice @$sublist, $index, 1, (); } =head2 watch_property $id = $obj->watch_property( $prop, %callbacks ) Watches a named property for changes, registering a set of callback functions to be invoked when the property changes in certain ways. The set of callbacks required depends on the dimension of the property being watched. For all property types: $on_set->( $obj, $value ) For hash properties: $on_add->( $obj, $key, $value ) $on_del->( $obj, $key ) For queue properties: $on_push->( $obj, @values ) $on_shift->( $obj, $count ) For array properties: $on_push->( $obj, @values ) $on_shift->( $obj, $count ) $on_splice->( $obj, $index, $count, @values ) $on_move->( $obj, $index, $delta ) For objset properties: $on_add->( $obj, $added_object ) $on_del->( $obj, $deleted_object_id ) Alternatively, a single callback may be installed that is invoked after any change of the property, being passed the new value entirely: $on_updated->( $obj, $value ) Returns an opaque ID value that can be used to remove this watch by calling C. =cut sub watch_property ( $self, $prop, %callbacks ) { my $pdef = $self->can_property( $prop ) or croak "$self has no property $prop"; my $callbacks = {}; my $on_updated; if( $callbacks{on_updated} ) { $on_updated = delete $callbacks{on_updated}; ref $on_updated eq "CODE" or croak "Expected 'on_updated' to be a CODE ref"; keys %callbacks and croak "Expected no key other than 'on_updated'"; $callbacks->{on_updated} = $on_updated; } else { foreach my $name ( @{ CHANGETYPES->{$pdef->dimension} } ) { ref( $callbacks->{$name} = delete $callbacks{$name} ) eq "CODE" or croak "Expected '$name' as a CODE ref"; } } my $watchlist = $self->{properties}->{$prop}->callbacks; push @$watchlist, $callbacks; $on_updated->( $self, $self->{properties}->{$prop}->value ) if $on_updated; my $ref = \@{$watchlist}[$#$watchlist]; # reference to last element return $ref + 0; # force numeric context } =head2 unwatch_property $obj->unwatch_property( $prop, $id ) Removes the set of callback functions previously registered with C. =cut sub unwatch_property ( $self, $prop, $id ) { my $watchlist = $self->{properties}->{$prop}->callbacks or return; my $index; for( $index = 0; $index < @$watchlist; $index++ ) { last if \@{$watchlist}[$index] + 0 == $id; } splice @$watchlist, $index, 1, (); } ### Message handling sub handle_request_CALL ( $self, $ctx, $message ) { my $method = $message->unpack_str(); my $mdef = $self->can_method( $method ) or die "Object cannot respond to method $method\n"; my $m = "method_$method"; $self->can( $m ) or die "Object cannot run method $method\n"; my @args = map { $_->unpack_value( $message ) } $mdef->argtypes; my $result = $self->$m( $ctx, @args ); my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); $mdef->ret->pack_value( $response, $result ) if $mdef->ret; return $response; } sub generate_message_EVENT ( $self, $conn, $event, @args ) { my $edef = $self->can_event( $event ) or die "Object cannot respond to event $event"; my $response = Tangence::Message->new( $conn, MSG_EVENT ) ->pack_int( $self->id ) ->pack_str( $event ); my @argtypes = $edef->argtypes; $argtypes[$_]->pack_value( $response, $args[$_] ) for 0..$#argtypes; return $response; } sub handle_request_GETPROP ( $self, $ctx, $message ) { my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; my $m = "get_prop_$prop"; $self->can( $m ) or die "Object cannot get property $prop\n"; my $result = $self->$m(); my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); $pdef->overall_type->pack_value( $response, $result ); return $response; } sub handle_request_GETPROPELEM ( $self, $ctx, $message ) { my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; my $dim = $pdef->dimension; my $m = "get_prop_$prop"; $self->can( $m ) or die "Object cannot get property $prop\n"; my $result; match( $dim : == ) { case( DIM_QUEUE ), case( DIM_ARRAY ) { my $idx = $message->unpack_int(); $result = $self->$m()->[$idx]; } case( DIM_HASH ) { my $key = $message->unpack_str(); $result = $self->$m()->{$key}; } default { die "Property $prop cannot fetch elements"; } } my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); $pdef->type->pack_value( $response, $result ); return $response; } sub handle_request_SETPROP ( $self, $ctx, $message ) { my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; my $value = $pdef->overall_type->unpack_value( $message ); my $m = "set_prop_$prop"; $self->can( $m ) or die "Object cannot set property $prop\n"; $self->$m( $value ); return Tangence::Message->new( $self, MSG_OK ); } sub generate_message_UPDATE ( $self, $conn, $prop, $how, @args ) { my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; my $dim = $pdef->dimension; my $message = Tangence::Message->new( $conn, MSG_UPDATE ) ->pack_int( $self->id ) ->pack_str( $prop ); TYPE_U8->pack_value( $message, $how ); my $dimname = DIMNAMES->[$dim]; if( $how == CHANGE_SET ) { my ( $value ) = @args; $pdef->overall_type->pack_value( $message, $value ); } elsif( my $code = $self->can( "_generate_message_UPDATE_$dimname" ) ) { $code->( $self, $message, $how, $pdef, @args ); } else { croak "Unrecognised property dimension $dim for $prop"; } return $message; } sub _generate_message_UPDATE_scalar ( $self, $message, $how, $pdef, @args ) { croak "Change type $how is not valid for a scalar property"; } sub _generate_message_UPDATE_hash ( $self, $message, $how, $pdef, @args ) { match( $how : == ) { case( CHANGE_ADD ) { my ( $key, $value ) = @args; $message->pack_str( $key ); $pdef->type->pack_value( $message, $value ); } case( CHANGE_DEL ) { my ( $key ) = @args; $message->pack_str( $key ); } default { croak "Change type $how is not valid for a hash property"; } } } sub _generate_message_UPDATE_queue ( $self, $message, $how, $pdef, @args ) { match( $how : == ) { case( CHANGE_PUSH ) { $message->pack_all_sametype( $pdef->type, @args ); } case( CHANGE_SHIFT ) { my ( $count ) = @args; $message->pack_int( $count ); } default { croak "Change type $how is not valid for a queue property"; } } } sub _generate_message_UPDATE_array ( $self, $message, $how, $pdef, @args ) { match( $how : == ) { case( CHANGE_PUSH ) { $message->pack_all_sametype( $pdef->type, @args ); } case( CHANGE_SHIFT ) { my ( $count ) = @args; $message->pack_int( $count ); } case( CHANGE_SPLICE ) { my ( $start, $count, @values ) = @args; $message->pack_int( $start ); $message->pack_int( $count ); $message->pack_all_sametype( $pdef->type, @values ); } case( CHANGE_MOVE ) { my ( $index, $delta ) = @args; $message->pack_int( $index ); $message->pack_int( $delta ); } default { croak "Change type $how is not valid for an array property"; } } } sub _generate_message_UPDATE_objset ( $self, $message, $how, $pdef, @args ) { match( $how : == ) { case( CHANGE_ADD ) { my ( $value ) = @args; $pdef->type->pack_value( $message, $value ); } case( CHANGE_DEL ) { my ( $id ) = @args; $message->pack_int( $id ); } default { croak "Change type $how is not valid for an objset property"; } } } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/ObjectProxy.pm000444001750001750 6070514174566136 17212 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::ObjectProxy 0.28; class Tangence::ObjectProxy; use Carp; use Syntax::Keyword::Match 0.06; use Future::AsyncAwait; use Future::Exception; use Tangence::Constants; use Tangence::Types; use Scalar::Util qw( weaken ); =head1 NAME C - proxy for a C object in a C =head1 DESCRIPTION Instances in this class act as a proxy for an object in the L, allowing methods to be called, events to be subscribed to, and properties to be watched. These objects are not directly constructed by calling the C class method; instead they are returned by methods on L, or by methods on other C instances. Ultimately every object proxy that a client uses will come from either the proxy to the registry, or the root object. =cut has $_client :param :weak :reader; has $_id :param :reader; has $_class :param :reader; has $_destroyed; has %_subscriptions; has %_props; method destroy { $_destroyed = 1; foreach my $cb ( @{ $_subscriptions{destroy} } ) { $cb->(); } } =head1 METHODS The following methods documented in an C expression return L instances. =cut use overload '""' => \&STRING; method STRING { return "Tangence::ObjectProxy[id=$_id]"; } =head2 id $id = $proxy->id Returns the object ID for the C object being proxied for. =cut # generated accessor =head2 classname $classname = $proxy->classname Returns the name of the class of the C object being proxied for. =cut method classname { return $_class->name; } =head2 class $class = $proxyobj->class Returns the L object representing the class of this object. =cut # generated accessor =head2 can_method $method = $proxy->can_method( $name ) Returns the L object representing the named method, or C if no such method exists. =cut method can_method { return $_class->method( @_ ); } =head2 can_event $event = $proxy->can_event( $name ) Returns the L object representing the named event, or C if no such event exists. =cut method can_event { return $_class->event( @_ ); } =head2 can_property $property = $proxy->can_property( $name ) Returns the L object representing the named property, or C if no such property exists. =cut method can_property { return $_class->property( @_ ); } # Don't want to call it "isa" method proxy_isa { if( @_ ) { my ( $class ) = @_; return !! grep { $_->name eq $class } $_class, $_class->superclasses; } else { return $_class, $_class->superclasses } } method grab ( $smashdata ) { foreach my $property ( keys %{ $smashdata } ) { my $value = $smashdata->{$property}; my $dim = $self->can_property( $property )->dimension; if( $dim == DIM_OBJSET ) { # Comes across in a LIST. We need to map id => obj $value = { map { $_->id => $_ } @$value }; } my $prop = $_props{$property} ||= {}; $prop->{cache} = $value; } } =head2 call_method $result = await $proxy->call_method( $mname, @args ) Calls the given method on the server object, passing in the given arguments. Returns a L that will yield the method's result. =cut async method call_method ( $method, @args ) { # Detect void-context legacy uses defined wantarray or croak "->call_method in void context no longer useful - it now returns a Future"; my $mdef = $self->can_method( $method ) or croak "Class ".$self->classname." does not have a method $method"; my $request = Tangence::Message->new( $_client, MSG_CALL ) ->pack_int( $self->id ) ->pack_str( $method ); my @argtypes = $mdef->argtypes; $argtypes[$_]->pack_value( $request, $args[$_] ) for 0..$#argtypes; my $message = await $_client->request( request => $request ); my $code = $message->code; if( $code == MSG_RESULT ) { my $result = $mdef->ret ? $mdef->ret->unpack_value( $message ) : undef; return $result; } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } =head2 subscribe_event await $proxy->subscribe_event( $event, %callbacks ) Subscribes to the given event on the server object, installing a callback function which will be invoked whenever the event is fired. Takes the following named callbacks: =over 8 =item on_fire => CODE Callback function to invoke whenever the event is fired $on_fire->( @args ) The returned C it is guaranteed to be completed before any invocation of the C event handler. =back =cut async method subscribe_event ( $event, %args ) { # Detect void-context legacy uses defined wantarray or croak "->subscribe_event in void context no longer useful - it now returns a Future"; ref( my $callback = delete $args{on_fire} ) eq "CODE" or croak "Expected 'on_fire' as a CODE ref"; $self->can_event( $event ) or croak "Class ".$self->classname." does not have an event $event"; if( my $cbs = $_subscriptions{$event} ) { push @$cbs, $callback; return; } my @cbs = ( $callback ); $_subscriptions{$event} = \@cbs; return if $event eq "destroy"; # This is automatically handled my $message = await $_client->request( request => Tangence::Message->new( $_client, MSG_SUBSCRIBE ) ->pack_int( $self->id ) ->pack_str( $event ) ); my $code = $message->code; if( $code == MSG_SUBSCRIBED ) { return; } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } method handle_request_EVENT ( $message ) { my $event = $message->unpack_str(); my $edef = $self->can_event( $event ) or return; my @args = map { $_->unpack_value( $message ) } $edef->argtypes; if( my $cbs = $_subscriptions{$event} ) { foreach my $cb ( @$cbs ) { $cb->( @args ) } } } =head2 unsubscribe_event $proxy->unsubscribe_event( $event ) Removes an event subscription on the given event on the server object that was previously installed using C. =cut method unsubscribe_event ( $event ) { $self->can_event( $event ) or croak "Class ".$self->classname." does not have an event $event"; return if $event eq "destroy"; # This is automatically handled $_client->request( request => Tangence::Message->new( $_client, MSG_UNSUBSCRIBE ) ->pack_int( $self->id ) ->pack_str( $event ), on_response => sub {}, ); } =head2 get_property await $value = $proxy->get_property( $prop ) Requests the current value of the property from the server object. =cut async method get_property ( $property ) { # Detect void-context legacy uses defined wantarray or croak "->get_property in void context no longer useful - it now returns a Future"; my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; my $message = await $_client->request( request => Tangence::Message->new( $_client, MSG_GETPROP ) ->pack_int( $self->id ) ->pack_str( $property ), ); my $code = $message->code; if( $code == MSG_RESULT ) { return $pdef->overall_type->unpack_value( $message ); } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } =head2 get_property_element await $value = $proxy->get_property_element( $property, $index_or_key ) Requests the current value of an element of the property from the server object. =cut async method get_property_element ( $property, $index_or_key ) { # Detect void-context legacy uses defined wantarray or croak "->get_property_element in void context no longer useful - it now returns a Future"; my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; my $request = Tangence::Message->new( $_client, MSG_GETPROPELEM ) ->pack_int( $self->id ) ->pack_str( $property ); match( $pdef->dimension : == ) { case( DIM_HASH ) { $request->pack_str( $index_or_key ); } case( DIM_ARRAY ), case( DIM_QUEUE ) { $request->pack_int( $index_or_key ); } default { croak "Cannot get_property_element of a non hash, array or queue"; } } my $message = await $_client->request( request => $request, ); my $code = $message->code; if( $code == MSG_RESULT ) { return $pdef->type->unpack_value( $message ); } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } =head2 prop $value = $proxy->prop( $property ) Returns the locally-cached value of a smashed property. If the named property is not a smashed property, an exception is thrown. =cut method prop ( $property ) { if( exists $_props{$property}->{cache} ) { return $_props{$property}->{cache}; } croak "$self does not have a cached property '$property'"; } =head2 set_property await $proxy->set_property( $prop, $value ) Sets the value of the property in the server object. =cut async method set_property ( $property, $value ) { # Detect void-context legacy uses defined wantarray or croak "->set_property in void context no longer useful - it now returns a Future"; my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; my $request = Tangence::Message->new( $_client, MSG_SETPROP ) ->pack_int( $self->id ) ->pack_str( $property ); $pdef->overall_type->pack_value( $request, $value ); my $message = await $_client->request( request => $request, ); my $code = $message->code; if( $code == MSG_OK ) { return; } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } =head2 watch_property await $proxy->watch_property( $property, %callbacks ) =head2 watch_property_with_initial await $proxy->watch_property_with_initial( $property, %callbacks ) Watches the given property on the server object, installing callback functions which will be invoked whenever the property value changes. The latter form additionally ensures that the server will send the current value of the property as an initial update to the C event, atomically when it installs the update watches. Takes the following named arguments: =over 8 =item on_updated => CODE Optional. Callback function to invoke whenever the property value changes. $on_updated->( $new_value ) If not provided, then individual handlers for individual change types must be provided. =back The set of callback functions that are required depends on the type of the property. These are documented in the C method of L. =cut sub _watchcbs_from_args ( $pdef, %args ) { my $callbacks = {}; my $on_updated = delete $args{on_updated}; if( $on_updated ) { ref $on_updated eq "CODE" or croak "Expected 'on_updated' to be a CODE ref"; $callbacks->{on_updated} = $on_updated; } foreach my $name ( @{ CHANGETYPES->{$pdef->dimension} } ) { # All of these become optional if 'on_updated' is supplied next if $on_updated and not exists $args{$name}; ref( $callbacks->{$name} = delete $args{$name} ) eq "CODE" or croak "Expected '$name' as a CODE ref"; } return $callbacks; } method watch_property { $self->_watch_property( shift, 0, @_ ) } method watch_property_with_initial { $self->_watch_property( shift, 1, @_ ) } async method _watch_property ( $property, $want_initial, %args ) { # Detect void-context legacy uses defined wantarray or croak "->watch_property in void context no longer useful - it now returns a Future"; my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; my $callbacks = _watchcbs_from_args( $pdef, %args ); # Smashed properties behave differently my $smash = $pdef->smashed; if( my $cbs = $_props{$property}->{cbs} ) { if( $want_initial and !$smash ) { my $value = await $self->get_property( $property ); $callbacks->{on_set} and $callbacks->{on_set}->( $value ); $callbacks->{on_updated} and $callbacks->{on_updated}->( $value ); push @$cbs, $callbacks; return; } elsif( $want_initial and $smash ) { my $cache = $_props{$property}->{cache}; $callbacks->{on_set} and $callbacks->{on_set}->( $cache ); $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache ); push @$cbs, $callbacks; return; } else { push @$cbs, $callbacks; return; } die "UNREACHED"; } $_props{$property}->{cbs} = [ $callbacks ]; if( $smash ) { if( $want_initial ) { my $cache = $_props{$property}->{cache}; $callbacks->{on_set} and $callbacks->{on_set}->( $cache ); $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache ); } return; } my $request = Tangence::Message->new( $_client, MSG_WATCH ) ->pack_int( $self->id ) ->pack_str( $property ) ->pack_bool( $want_initial ); my $message = await $_client->request( request => $request ); my $code = $message->code; if( $code == MSG_WATCHING ) { return; } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } =head2 watch_property_with_cursor ( $cursor, $first_idx, $last_idx ) = await $proxy->watch_property_with_cursor( $property, $from, %callbacks ) A variant of C that installs a watch on the given property of the server object, and additionally returns an cursor object that can be used to lazily fetch the values stored in it. The C<$from> value indicates which end of the queue the cursor should start from; C to start at index 0, or C to start at the highest-numbered index. The cursor is created atomically with installing the watch. =cut method watch_property_with_iter { # Detect void-context legacy uses defined wantarray or croak "->watch_property_with_iter in void context no longer useful - it now returns a Future"; return $self->watch_property_with_cursor( @_ ); } async method watch_property_with_cursor ( $property, $from, %args ) { match( $from : eq ) { case( "first" ) { $from = CUSR_FIRST } case( "last" ) { $from = CUSR_LAST } default { croak "Unrecognised 'from' value $from" } } my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; my $callbacks = _watchcbs_from_args( $pdef, %args ); # Smashed properties behave differently my $smashed = $pdef->smashed; if( my $cbs = $_props{$property}->{cbs} ) { die "TODO: need to synthesize a second cursor for $self"; } $_props{$property}->{cbs} = [ $callbacks ]; if( $smashed ) { die "TODO: need to synthesize an cursor"; } $pdef->dimension == DIM_QUEUE or croak "Can only iterate on queue-dimension properties"; my $message = await $_client->request( request => Tangence::Message->new( $_client, MSG_WATCH_CUSR ) ->pack_int( $self->id ) ->pack_str( $property ) ->pack_int( $from ), ); my $code = $message->code; if( $code == MSG_WATCHING_CUSR ) { my $cursor_id = $message->unpack_int(); my $first_idx = $message->unpack_int(); my $last_idx = $message->unpack_int(); my $cursor = Tangence::ObjectProxy::_Cursor->new( $self, $cursor_id, $pdef->type ); return ( $cursor, $first_idx, $last_idx ); } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } method handle_request_UPDATE ( $message ) { my $prop = $message->unpack_str(); my $how = TYPE_U8->unpack_value( $message ); my $pdef = $self->can_property( $prop ) or return; my $type = $pdef->type; my $dim = $pdef->dimension; my $p = $_props{$prop} ||= {}; my $dimname = DIMNAMES->[$dim]; if( my $code = $self->can( "_update_property_$dimname" ) ) { $code->( $self, $p, $type, $how, $message ); } else { croak "Unrecognised property dimension $dim for $prop"; } $_->{on_updated} and $_->{on_updated}->( $p->{cache} ) for @{ $p->{cbs} }; } method _update_property_scalar ( $p, $type, $how, $message ) { match( $how : == ) { case( CHANGE_SET ) { my $value = $type->unpack_value( $message ); $p->{cache} = $value; $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } default { croak "Change type $how is not valid for a scalar property"; } } } method _update_property_hash ( $p, $type, $how, $message ) { match( $how : == ) { case( CHANGE_SET ) { my $value = Tangence::Type->make( dict => $type )->unpack_value( $message ); $p->{cache} = $value; $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } case( CHANGE_ADD ) { my $key = $message->unpack_str(); my $value = $type->unpack_value( $message ); $p->{cache}->{$key} = $value; $_->{on_add} and $_->{on_add}->( $key, $value ) for @{ $p->{cbs} }; } case( CHANGE_DEL ) { my $key = $message->unpack_str(); delete $p->{cache}->{$key}; $_->{on_del} and $_->{on_del}->( $key ) for @{ $p->{cbs} }; } default { croak "Change type $how is not valid for a hash property"; } } } method _update_property_queue ( $p, $type, $how, $message ) { match( $how : == ) { case( CHANGE_SET ) { my $value = Tangence::Type->make( list => $type )->unpack_value( $message ); $p->{cache} = $value; $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } case( CHANGE_PUSH ) { my @value = $message->unpack_all_sametype( $type ); push @{ $p->{cache} }, @value; $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; } case( CHANGE_SHIFT ) { my $count = $message->unpack_int(); splice @{ $p->{cache} }, 0, $count, (); $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; } default { croak "Change type $how is not valid for a queue property"; } } } method _update_property_array ( $p, $type, $how, $message ) { match( $how : == ) { case( CHANGE_SET ) { my $value = Tangence::Type->make( list => $type )->unpack_value( $message ); $p->{cache} = $value; $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } case( CHANGE_PUSH ) { my @value = $message->unpack_all_sametype( $type ); push @{ $p->{cache} }, @value; $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; } case( CHANGE_SHIFT ) { my $count = $message->unpack_int(); splice @{ $p->{cache} }, 0, $count, (); $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; } case( CHANGE_SPLICE ) { my $start = $message->unpack_int(); my $count = $message->unpack_int(); my @value = $message->unpack_all_sametype( $type ); splice @{ $p->{cache} }, $start, $count, @value; $_->{on_splice} and $_->{on_splice}->( $start, $count, @value ) for @{ $p->{cbs} }; } case( CHANGE_MOVE ) { my $index = $message->unpack_int(); my $delta = $message->unpack_int(); # it turns out that exchanging neighbours is quicker by list assignment, # but other times it's generally best to use splice() to extract then # insert if( abs($delta) == 1 ) { @{$p->{cache}}[$index,$index+$delta] = @{$p->{cache}}[$index+$delta,$index]; } else { my $elem = splice @{ $p->{cache} }, $index, 1, (); splice @{ $p->{cache} }, $index + $delta, 0, ( $elem ); } $_->{on_move} and $_->{on_move}->( $index, $delta ) for @{ $p->{cbs} }; } default { croak "Change type $how is not valid for an array property"; } } } method _update_property_objset ( $p, $type, $how, $message ) { match( $how : == ) { case( CHANGE_SET ) { # Comes across in a LIST. We need to map id => obj my $objects = Tangence::Type->make( list => $type )->unpack_value( $message ); $p->{cache} = { map { $_->id => $_ } @$objects }; $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } case( CHANGE_ADD ) { # Comes as object only my $obj = $type->unpack_value( $message ); $p->{cache}->{$obj->id} = $obj; $_->{on_add} and $_->{on_add}->( $obj ) for @{ $p->{cbs} }; } case( CHANGE_DEL ) { # Comes as ID number only my $id = $message->unpack_int(); delete $p->{cache}->{$id}; $_->{on_del} and $_->{on_del}->( $id ) for @{ $p->{cbs} }; } default { croak "Change type $how is not valid for an objset property"; } } } =head2 unwatch_property $proxy->unwatch_property( $property ) Removes a property watches on the given property on the server object that was previously installed using C. =cut method unwatch_property ( $property ) { $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; # TODO: mark cursors as destroyed and invalid delete $_props{$property}; $_client->request( request => Tangence::Message->new( $_client, MSG_UNWATCH ) ->pack_int( $self->id ) ->pack_str( $property ), on_response => sub {}, ); } class Tangence::ObjectProxy::_Cursor { use Carp; use Tangence::Constants; =head1 CURSOR METHODS The following methods are availilable on the property cursor objects returned by the C method. =cut has $obj :param :reader; has $id :param :reader; has $element_type :param; sub BUILDARGS ( $class, $obj, $id, $element_type ) { return ( obj => $obj, id => $id, element_type => $element_type ); } method client { $obj->client } # TODO: Object::Pad probably should do this bit method DESTROY { return unless $obj and my $client = $self->client; $client->request( request => Tangence::Message->new( $client, MSG_CUSR_DESTROY ) ->pack_int( $id ), on_response => sub {}, ); } =head2 next_forward ( $index, @more ) = await $cursor->next_forward( $count ) =head2 next_backward ( $index, @more ) = await $cursor->next_backward( $count ) Requests the next items from the cursor. C moves forwards towards higher-numbered indices, and C moves backwards towards lower-numbered indices. If C<$count> is unspecified, a default of 1 will apply. The returned future wil yield the index of the first element returned, and the new elements. Note that there may be fewer elements returned than were requested, if the end of the queue was reached. Specifically, there will be no new elements if the cursor is already at the end. =cut method next_forward { $self->_next( CUSR_FWD, @_ ); } method next_backward { $self->_next( CUSR_BACK, @_ ); } async method _next ( $direction, $count = 1 ) { # Detect void-context legacy uses defined wantarray or croak "->next_forward/backward in void context no longer useful - it now returns a Future"; my $client = $self->client; my $message = await $client->request( request => Tangence::Message->new( $client, MSG_CUSR_NEXT ) ->pack_int( $id ) ->pack_int( $direction ) ->pack_int( $count || 1 ), ); my $code = $message->code; if( $code == MSG_CUSR_RESULT ) { return ( $message->unpack_int(), $message->unpack_all_sametype( $element_type ), ); } else { Future::Exception->throw( "Unexpected response code $code", tangence => ); } } } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Property.pm000444001750001750 2223114174566136 16556 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Property 0.28; use warnings; use base qw( Tangence::Meta::Property ); use Carp; use Tangence::Constants; require Tangence::Type; use Struct::Dumb; struct Instance => [qw( value callbacks cursors )]; sub build_accessor { my $prop = shift; my ( $subs ) = @_; my $pname = $prop->name; my $dim = $prop->dimension; $subs->{"new_prop_$pname"} = sub { my $self = shift; my $initial; if( my $code = $self->can( "init_prop_$pname" ) ) { $initial = $code->( $self ); } elsif( $dim == DIM_SCALAR ) { $initial = $prop->type->default_value; } elsif( $dim == DIM_HASH ) { $initial = {}; } elsif( $dim == DIM_QUEUE or $dim == DIM_ARRAY ) { $initial = []; } elsif( $dim == DIM_OBJSET ) { $initial = {}; # these have hashes internally } else { croak "Unrecognised dimension $dim for property $pname"; } $self->{properties}->{$pname} = Instance( $initial, [], [] ); }; $subs->{"get_prop_$pname"} = sub { my $self = shift; return $self->{properties}->{$pname}->value; }; $subs->{"set_prop_$pname"} = sub { my $self = shift; my ( $newval ) = @_; $self->{properties}->{$pname}->value = $newval; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_set}->( $self, $newval ) for @$cbs; }; my $dimname = DIMNAMES->[$dim]; if( my $code = __PACKAGE__->can( "_accessor_for_$dimname" ) ) { $code->( $prop, $subs, $pname ); } else { croak "Unrecognised property dimension $dim for $pname"; } } sub _accessor_for_scalar { # Nothing needed } sub _accessor_for_hash { my $prop = shift; my ( $subs, $pname ) = @_; $subs->{"add_prop_$pname"} = sub { my $self = shift; my ( $key, $value ) = @_; $self->{properties}->{$pname}->value->{$key} = $value; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_add}->( $self, $key, $value ) for @$cbs; }; $subs->{"del_prop_$pname"} = sub { my $self = shift; my ( $key ) = @_; delete $self->{properties}->{$pname}->value->{$key}; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_del}->( $self, $key ) for @$cbs; }; } sub _accessor_for_queue { my $prop = shift; my ( $subs, $pname ) = @_; $subs->{"push_prop_$pname"} = sub { my $self = shift; my @values = @_; push @{ $self->{properties}->{$pname}->value }, @values; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_push}->( $self, @values ) for @$cbs; }; $subs->{"shift_prop_$pname"} = sub { my $self = shift; my ( $count ) = @_; $count = 1 unless @_; splice @{ $self->{properties}->{$pname}->value }, 0, $count, (); my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_shift}->( $self, $count ) for @$cbs; my $cursors = $self->{properties}->{$pname}->cursors; $_->idx -= $count for @$cursors; }; $subs->{"cursor_prop_$pname"} = sub { my $self = shift; my ( $from ) = @_; my $idx = $from == CUSR_FIRST ? 0 : $from == CUSR_LAST ? scalar @{ $self->{properties}->{$pname}->value } : die "Unrecognised from"; my $cursors = $self->{properties}->{$pname}->cursors ||= []; push @$cursors, my $cursor = Tangence::Property::_Cursor->new( $self->{properties}->{$pname}->value, $prop, $idx ); return $cursor; }; $subs->{"uncursor_prop_$pname"} = sub { my $self = shift; my ( $cursor ) = @_; my $cursors = $self->{properties}->{$pname}->cursors or return; @$cursors = grep { $_ != $cursor } @$cursors; }; } sub _accessor_for_array { my $prop = shift; my ( $subs, $pname ) = @_; $subs->{"push_prop_$pname"} = sub { my $self = shift; my @values = @_; push @{ $self->{properties}->{$pname}->value }, @values; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_push}->( $self, @values ) for @$cbs; }; $subs->{"shift_prop_$pname"} = sub { my $self = shift; my ( $count ) = @_; $count = 1 unless @_; splice @{ $self->{properties}->{$pname}->value }, 0, $count, (); my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_shift}->( $self, $count ) for @$cbs; }; $subs->{"splice_prop_$pname"} = sub { my $self = shift; my ( $index, $count, @values ) = @_; splice @{ $self->{properties}->{$pname}->value }, $index, $count, @values; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_splice}->( $self, $index, $count, @values ) for @$cbs; }; $subs->{"move_prop_$pname"} = sub { my $self = shift; my ( $index, $delta ) = @_; return if $delta == 0; # it turns out that exchanging neighbours is quicker by list assignment, # but other times it's generally best to use splice() to extract then # insert my $cache = $self->{properties}->{$pname}->value; if( abs($delta) == 1 ) { @{$cache}[$index,$index+$delta] = @{$cache}[$index+$delta,$index]; } else { my $elem = splice @$cache, $index, 1, (); splice @$cache, $index + $delta, 0, ( $elem ); } my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_move}->( $self, $index, $delta ) for @$cbs; }; } sub _accessor_for_objset { my $prop = shift; my ( $subs, $pname ) = @_; # Different get and set methods $subs->{"get_prop_$pname"} = sub { my $self = shift; return [ values %{ $self->{properties}->{$pname}->value } ]; }; $subs->{"set_prop_$pname"} = sub { my $self = shift; my ( $newval ) = @_; $self->{properties}->{$pname}->value = $newval; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_set}->( $self, [ values %$newval ] ) for @$cbs; }; $subs->{"add_prop_$pname"} = sub { my $self = shift; my ( $obj ) = @_; $self->{properties}->{$pname}->value->{$obj->id} = $obj; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_add}->( $self, $obj ) for @$cbs; }; $subs->{"del_prop_$pname"} = sub { my $self = shift; my ( $obj_or_id ) = @_; my $id = ref $obj_or_id ? $obj_or_id->id : $obj_or_id; delete $self->{properties}->{$pname}->value->{$id}; my $cbs = $self->{properties}->{$pname}->callbacks; $_->{on_updated} ? $_->{on_updated}->( $self, $self->{properties}->{$pname}->value ) : $_->{on_del}->( $self, $id ) for @$cbs; }; } sub make_type { shift; return Tangence::Type->make( @_ ); } class # hide from CPAN Tangence::Property::_Cursor { use Carp; use Tangence::Constants; has $queue :param :reader; has $prop :param :reader; has $idx :param :mutator; sub BUILDARGS ( $class, $queue, $prop, $idx ) { return ( queue => $queue, prop => $prop, idx => $idx ); } method handle_request_CUSR_NEXT { my ( $ctx, $message ) = @_; my $direction = $message->unpack_int(); my $count = $message->unpack_int(); my $start_idx = $idx; if( $direction == CUSR_FWD ) { $count = scalar @$queue - $idx if $count > scalar @$queue - $idx; $idx += $count; } elsif( $direction == CUSR_BACK ) { $count = $idx if $count > $idx; $idx -= $count; $start_idx = $idx; } else { return $ctx->responderr( "Unrecognised cursor direction $direction" ); } my @result = @{$queue}[$start_idx .. $start_idx + $count - 1]; $ctx->respond( Tangence::Message->new( $ctx->stream, MSG_CUSR_RESULT ) ->pack_int( $start_idx ) ->pack_all_sametype( $prop->type, @result ) ); } } 0x55AA; Tangence-0.28/lib/Tangence/Registry.pm000444001750001750 1014114174566136 16537 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.51; package Tangence::Registry 0.28; class Tangence::Registry isa Tangence::Object; use Carp; use Tangence::Constants; use Tangence::Class; use Tangence::Property; use Tangence::Struct; use Tangence::Type; use Tangence::Compiler::Parser; use Scalar::Util qw( weaken ); Tangence::Class->declare( __PACKAGE__, methods => { get_by_id => { args => [ [ id => 'int' ] ], ret => 'obj', }, }, events => { object_constructed => { args => [ [ id => 'int' ] ], }, object_destroyed => { args => [ [ id => 'int' ] ], }, }, props => { objects => { dim => DIM_HASH, type => 'str', } }, ); =head1 NAME C - object manager for a C server =head1 DESCRIPTION This subclass of L acts as a container for all the exposed objects in a L server. The registry is used to create exposed objects, and manages their lifetime. It maintains a reference to all the objects it creates, so it can dispatch incoming messages from clients to them. =cut =head1 CONSTRUCTOR =cut =head2 new $registry = Tangence::Registry->new Returns a new instance of a C object. An entire server requires one registry object; it will be shared among all the client connections to that server. =cut sub BUILDARGS ( $class, %args ) { return ( id => 0, registry => "BOOTSTRAP", meta => Tangence::Class->for_perlname( $class ), %args, ); } has $_nextid = 1; has @_freeids; has %_objects; ADJUST { my $id = 0; weaken( $self->{registry} = $self ); %_objects = ( $id => $self ); weaken( $_objects{$id} ); $self->add_prop_objects( $id => $self->describe ); } ADJUSTPARAMS ( $params ) { $self->load_tanfile( delete $params->{tanfile} ); } =head1 METHODS =cut =head2 get_by_id $obj = $registry->get_by_id( $id ) Returns the object with the given object ID. This method is exposed to clients. =cut method get_by_id ( $id ) { return $_objects{$id}; } method method_get_by_id ( $ctx, $id ) { return $self->get_by_id( $id ); } =head2 construct $obj = $registry->construct( $type, @args ) Constructs a new exposed object of the given type, and returns it. Any additional arguments are passed to the object's constructor. =cut method construct ( $type, @args ) { my $id = shift @_freeids // ( $_nextid++ ); Tangence::Class->for_perlname( $type ) or croak "Registry cannot construct a '$type' as no class definition exists"; eval { $type->can( "new" ) } or croak "Registry cannot construct a '$type' as it has no ->new() method"; my $obj = $type->new( registry => $self, id => $id, @args ); $self->fire_event( "object_constructed", $id ); weaken( $_objects{$id} = $obj ); $self->add_prop_objects( $id => $obj->describe ); return $obj; } method destroy_object ( $obj ) { my $id = $obj->id; exists $_objects{$id} or croak "Cannot destroy ID $id - does not exist"; $self->del_prop_objects( $id ); $self->fire_event( "object_destroyed", $id ); push @_freeids, $id; # Recycle the ID } =head2 load_tanfile $registry->load_tanfile( $tanfile ) Loads additional Tangence class and struct definitions from the given F<.tan> file. =cut method load_tanfile ( $tanfile ) { # Merely constructing this has the side-effect of declaring all the classes Tangence::Registry::Parser->new->from_file( $tanfile ); } class Tangence::Registry::Parser isa Tangence::Compiler::Parser { method make_class { return Tangence::Class->make( @_ ); } method make_struct { return Tangence::Struct->make( @_ ); } method make_property { return Tangence::Property->new( @_ ); } method make_type { return Tangence::Type->make( @_ ); } } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Server.pm000444001750001750 3613414174566136 16207 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk package Tangence::Server 0.28; use v5.26; use warnings; use experimental 'signatures'; use base qw( Tangence::Stream ); use Carp; use Scalar::Util qw( weaken ); use Sub::Util 1.40 qw( set_subname ); use Feature::Compat::Try; use Tangence::Constants; use Tangence::Types; use Tangence::Server::Context; use Struct::Dumb; struct CursorObject => [qw( cursor obj )]; # We will accept any version back to 3 use constant VERSION_MINOR_MIN => 3; =head1 NAME C - mixin class for building a C server =head1 SYNOPSIS This class is a mixin, it cannot be directly constructed package Example::Server; use base qw( Base::Server Tangence::Server ); sub new { my $class = shift; my %args = @_; my $registry = delete $args{registry}; my $self = $class->SUPER::new( %args ); $self->registry( $registry ); return $self; } sub tangence_write { my $self = shift; $self->write( $_[0] ); } sub on_read { my $self = shift; $self->tangence_readfrom( $_[0] ); } =head1 DESCRIPTION This module provides mixin to implement a C server connection. It should be mixed in to an object used to represent a single connection from a client. It provides a location for the objects in server to store information about the client connection, and coordinates passing messages between the client and the objects in the server. This is a subclass of L which provides implementations of the required C methods. A class mixing in C must still provide the C method required for sending data to the client. For an example of a class that uses this mixin, see L. =cut =head1 PROVIDED METHODS The following methods are provided by this mixin. =cut sub subscriptions { shift->{subscriptions} ||= [] } sub watches { shift->{watches} ||= [] } =head2 registry $server->registry( $registry ) $registry = $server->registry Accessor to set or obtain the L object for the server. =cut sub registry { my $self = shift; $self->{registry} = shift if @_; return $self->{registry}; } sub tangence_closed { my $self = shift; $self->SUPER::tangence_closed; if( my $subscriptions = $self->subscriptions ) { foreach my $s ( @$subscriptions ) { my ( $object, $event, $id ) = @$s; $object->unsubscribe_event( $event, $id ); } undef @$subscriptions; } if( my $watches = $self->watches ) { foreach my $w ( @$watches ) { my ( $object, $prop, $id ) = @$w; $object->unwatch_property( $prop, $id ); } undef @$watches; } if( my $cursors = $self->peer_hascursor ) { foreach my $cursorobj ( values %$cursors ) { $self->drop_cursorobj( $cursorobj ); } } } sub get_by_id ( $self, $id ) { # Only permit the client to interact with objects they've already been # sent, so they cannot gain access by inventing object IDs $self->peer_hasobj->{$id} or die "Access not allowed to object with id $id\n"; my $obj = $self->registry->get_by_id( $id ) or die "No such object with id $id\n"; return $obj; } sub handle_request_CALL ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $object = $self->get_by_id( $objid ); $response = $object->handle_request_CALL( $ctx, $message ); } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_SUBSCRIBE ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $event = $message->unpack_str(); my $object = $self->get_by_id( $objid ); weaken( my $weakself = $self ); my $id = $object->subscribe_event( $event, set_subname "__SUBSCRIBE($event)__" => sub { $weakself or return; my $object = shift; my $message = $object->generate_message_EVENT( $weakself, $event, @_ ); $weakself->request( request => $message, on_response => sub { "IGNORE" }, ); } ); push @{ $self->subscriptions }, [ $object, $event, $id ]; $response = Tangence::Message->new( $self, MSG_SUBSCRIBED ) } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_UNSUBSCRIBE ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $event = $message->unpack_str(); my $object = $self->get_by_id( $objid ); my $edef = $object->can_event( $event ) or die "Object cannot respond to event $event\n"; # Delete from subscriptions and obtain id my $id; @{ $self->subscriptions } = grep { $_->[0] == $object and $_->[1] eq $event and ( $id = $_->[2], 0 ) or 1 } @{ $self->subscriptions }; defined $id or die "Not subscribed to $event\n"; $object->unsubscribe_event( $event, $id ); $response = Tangence::Message->new( $self, MSG_OK ) } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_GETPROP ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $object = $self->get_by_id( $objid ); $response = $object->handle_request_GETPROP( $ctx, $message ) } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_GETPROPELEM ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $object = $self->get_by_id( $objid ); $response = $object->handle_request_GETPROPELEM( $ctx, $message ) } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_SETPROP ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $object = $self->get_by_id( $objid ); $response = $object->handle_request_SETPROP( $ctx, $message ) } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } *handle_request_WATCH = \&_handle_request_WATCHany; *handle_request_WATCH_CUSR = \&_handle_request_WATCHany; sub _handle_request_WATCHany ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my ( $want_initial, $object, $prop ); my $response; try { my $objid = $message->unpack_int(); $prop = $message->unpack_str(); $object = $self->get_by_id( $objid ); my $pdef = $object->can_property( $prop ) or die "Object does not have property $prop\n"; $self->_install_watch( $object, $prop ); if( $message->code == MSG_WATCH ) { $want_initial = $message->unpack_bool(); $response = Tangence::Message->new( $self, MSG_WATCHING ) } elsif( $message->code == MSG_WATCH_CUSR ) { my $from = $message->unpack_int(); my $m = "cursor_prop_$prop"; my $cursor = $object->$m( $from ); my $id = $self->message_state->{next_cursorid}++; $self->peer_hascursor->{$id} = CursorObject( $cursor, $object ); $response = Tangence::Message->new( $self, MSG_WATCHING_CUSR ) ->pack_int( $id ) ->pack_int( 0 ) # first index ->pack_int( $#{ $object->${\"get_prop_$prop"} } ) # last index } } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); $self->_send_initial( $object, $prop ) if $want_initial; } sub _send_initial ( $self, $object, $prop ) { my $m = "get_prop_$prop"; return unless( $object->can( $m ) ); try { my $value = $object->$m(); my $message = $object->generate_message_UPDATE( $self, $prop, CHANGE_SET, $value ); $self->request( request => $message, on_response => sub { "IGNORE" }, ); } catch ( $e ) { warn "$e during initial property fetch"; } } sub handle_request_UNWATCH ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; try { my $objid = $message->unpack_int(); my $prop = $message->unpack_str(); my $object = $self->get_by_id( $objid ); my $pdef = $object->can_property( $prop ) or die "Object does not have property $prop\n"; # Delete from watches and obtain id my $id; @{ $self->watches } = grep { $_->[0] == $object and $_->[1] eq $prop and ( $id = $_->[2], 0 ) or 1 } @{ $self->watches }; defined $id or die "Not watching $prop\n"; $object->unwatch_property( $prop, $id ); $response = Tangence::Message->new( $self, MSG_OK ); } catch ( $e ) { return $ctx->responderr( $e ); } $ctx->respond( $response ); } sub handle_request_CUSR_NEXT ( $self, $token, $message ) { my $cursor_id = $message->unpack_int(); my $ctx = Tangence::Server::Context->new( $self, $token ); my $cursorobj = $self->peer_hascursor->{$cursor_id} or return $ctx->responderr( "No such cursor with id $cursor_id" ); $cursorobj->cursor->handle_request_CUSR_NEXT( $ctx, $message ); } sub handle_request_CUSR_DESTROY ( $self, $token, $message ) { my $cursor_id = $message->unpack_int(); my $ctx = Tangence::Server::Context->new( $self, $token ); my $cursorobj = delete $self->peer_hascursor->{$cursor_id}; $self->drop_cursorobj( $cursorobj ); $ctx->respond( Tangence::Message->new( $self, MSG_OK ) ); } sub drop_cursorobj ( $self, $cursorobj ) { my $m = "uncursor_prop_" . $cursorobj->cursor->prop->name; $cursorobj->obj->$m( $cursorobj->cursor ); } sub handle_request_INIT ( $self, $token, $message ) { my $major = $message->unpack_int(); my $minor_max = $message->unpack_int(); my $minor_min = $message->unpack_int(); my $ctx = Tangence::Server::Context->new( $self, $token ); if( $major != VERSION_MAJOR ) { return $ctx->responderr( "Major version $major not available" ); } # Don't accept higher than the minor version we recognise $minor_max = VERSION_MINOR if $minor_max > VERSION_MINOR; $minor_min = VERSION_MINOR_MIN if $minor_min < VERSION_MINOR_MIN; if( $minor_max < $minor_min ) { return $ctx->responderr( "No suitable minor version available" ); } # For unit tests or other synchronous cases, we need to set the version # -before- we send the message. But we'd better construct the response # message before setting the version, in case it makes a difference. my $response = Tangence::Message->new( $self, MSG_INITED ) ->pack_int( $major ) ->pack_int( $minor_max ); $self->minor_version( $minor_max ); $ctx->respond( $response ); } sub handle_request_GETROOT ( $self, $token, $message ) { my $identity = TYPE_ANY->unpack_value( $message ); my $ctx = Tangence::Server::Context->new( $self, $token ); $self->identity( $identity ); my $root = $self->rootobj( $identity ); my $response = Tangence::Message->new( $self, MSG_RESULT ); TYPE_OBJ->pack_value( $response, $root ); $ctx->respond( $response ); } sub handle_request_GETREGISTRY ( $self, $token, $message ) { my $ctx = Tangence::Server::Context->new( $self, $token ); $self->permit_registry or return $ctx->responderr( "This client is not permitted access to the registry" ); my $response = Tangence::Message->new( $self, MSG_RESULT ); TYPE_OBJ->pack_value( $response, $self->registry ); $ctx->respond( $response ); } my %change_values = ( on_set => CHANGE_SET, on_add => CHANGE_ADD, on_del => CHANGE_DEL, on_push => CHANGE_PUSH, on_shift => CHANGE_SHIFT, on_splice => CHANGE_SPLICE, on_move => CHANGE_MOVE, ); sub _install_watch ( $self, $object, $prop ) { my $pdef = $object->can_property( $prop ); my $dim = $pdef->dimension; weaken( my $weakself = $self ); my %callbacks; foreach my $name ( @{ CHANGETYPES->{$dim} } ) { my $how = $change_values{$name}; $callbacks{$name} = set_subname "__WATCH($prop:$name)__" => sub { $weakself or return; my $object = shift; my $message = $object->generate_message_UPDATE( $weakself, $prop, $how, @_ ); $weakself->request( request => $message, on_response => sub { "IGNORE" }, ); }; } my $id = $object->watch_property( $prop, %callbacks ); push @{ $self->watches }, [ $object, $prop, $id ]; } sub object_destroyed ( $self, $obj, @rest ) { if( my $subs = $self->subscriptions ) { my $i = 0; while( $i < @$subs ) { my $s = $subs->[$i]; $i++, next unless $s->[0] == $obj; my ( undef, $event, $id ) = @$s; $obj->unsubscribe_event( $event, $id ); splice @$subs, $i, 1; # No $i++ } } if( my $watches = $self->watches ) { my $i = 0; while( $i < @$watches ) { my $w = $watches->[$i]; $i++, next unless $w->[0] == $obj; my ( undef, $prop, $id ) = @$w; $obj->unwatch_property( $prop, $id ); splice @$watches, $i, 1; # No $i++ } } $self->SUPER::object_destroyed( $obj, @rest ); } =head1 OVERRIDEABLE METHODS The following methods are provided but intended to be overridden if the implementing class wishes to provide different behaviour from the default. =cut =head2 rootobj $rootobj = $server->rootobj( $identity ) Invoked when a C message is received from the client, this method should return a L as root object for the connection. The default implementation will return the object with ID 1; i.e. the first object created in the registry. =cut sub rootobj { my $self = shift; return $self->registry->get_by_id( 1 ); } =head2 permit_registry $allow = $server->permit_registry Invoked when a C message is received from the client, this method should return a boolean to indicate whether the client is allowed to access the object registry. The default implementation always permits this, but an overridden method may decide to disallow it in some situations. When disabled, a client will not be able to gain access to any serverside objects other than the root object, and (recursively) any other objects returned by methods, events or properties on objects already known. This can be used as a security mechanism. =cut sub permit_registry { 1; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Stream.pm000444001750001750 2242014174566136 16165 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2020 -- leonerd@leonerd.org.uk package Tangence::Stream 0.28; use v5.26; use warnings; use experimental 'signatures'; use Carp; use Tangence::Constants; use Tangence::Message; # A map from request codes to method names # Can't use => operator because it would quote the barewords on the left, but # we want them as constants my %REQ_METHOD = ( MSG_CALL, 'handle_request_CALL', MSG_SUBSCRIBE, 'handle_request_SUBSCRIBE', MSG_UNSUBSCRIBE, 'handle_request_UNSUBSCRIBE', MSG_EVENT, 'handle_request_EVENT', MSG_GETPROP, 'handle_request_GETPROP', MSG_GETPROPELEM, 'handle_request_GETPROPELEM', MSG_SETPROP, 'handle_request_SETPROP', MSG_WATCH, 'handle_request_WATCH', MSG_UNWATCH, 'handle_request_UNWATCH', MSG_UPDATE, 'handle_request_UPDATE', MSG_DESTROY, 'handle_request_DESTROY', MSG_WATCH_CUSR, 'handle_request_WATCH_CUSR', MSG_CUSR_NEXT, 'handle_request_CUSR_NEXT', MSG_CUSR_DESTROY, 'handle_request_CUSR_DESTROY', MSG_GETROOT, 'handle_request_GETROOT', MSG_GETREGISTRY, 'handle_request_GETREGISTRY', MSG_INIT, 'handle_request_INIT', ); =head1 NAME C - base class for C stream-handling mixins =head1 DESCRIPTION This module provides a base for L and L. It is not intended to be used directly by C implementation code. It provides the basic layer of message serialisation, deserialisation, and dispatching to methods that would handle the messages. Higher level classes are used to wrap this functionallity, and provide implementations of methods to handle the messages received. When a message is received, it will be passed to a method whose name depends on the code of message received. The name will be C, followed by the name of the message code, in uppercase; for example C. =cut =head1 REQUIRED METHODS The following methods are required to be implemented by some class using this mixin. =cut =head2 tangence_write $stream->tangence_write( $data ) Write bytes of data to the connected peer. C<$data> will be a plain perl string. =cut =head2 handle_request_$CODE $stream->handle_request_$CODE( $token, $message ) Invoked on receipt of a given message code. C<$token> will be some opaque perl scalar value, and C<$message> will be an instance of L. The value of the token has no particular meaning, other than to be passed to the C method. =cut =head1 PROVIDED METHODS The following methods are provided by this mixin. =cut # Accessors for Tangence::Message decoupling our $BUILTIN_STRUCTIDS; our %BUILTIN_ID2STRUCT; our %ALWAYS_PEER_HASSTRUCT; sub message_state { shift->{message_state} ||= { id2struct => { %BUILTIN_ID2STRUCT }, next_structid => $BUILTIN_STRUCTIDS, next_cursorid => 1, } } sub peer_hasobj { shift->{peer_hasobj} ||= {} } sub peer_hasclass { shift->{peer_hasclass} ||= {} } sub peer_hasstruct { shift->{peer_hasstruct} ||= { %ALWAYS_PEER_HASSTRUCT } } sub peer_hascursor { shift->{peer_hascursor} ||= {} } sub identity { my $self = shift; $self->{identity} = shift if @_; return $self->{identity}; } =head2 tangence_closed $stream->tangence_closed Informs the object that the underlying connection has now been closed, and any attachments to C or C instances should now be dropped. =cut sub tangence_closed { my $self = shift; foreach my $id ( keys %{ $self->peer_hasobj } ) { my $obj = $self->get_by_id( $id ); $obj->unsubscribe_event( "destroy", delete $self->peer_hasobj->{$id} ); } } =head2 tangence_readfrom $stream->tangence_readfrom( $buffer ) Informs the object that more data has been read from the underlying connection stream. Whole messages will be removed from the beginning of the C<$buffer>, which should be passed as a direct scalar (because it will be modified). This method will invoke the required C methods. Any bytes remaining that form the start of a partial message will be left in the buffer. =cut sub tangence_readfrom { my $self = shift; while( length $_[0] ) { last unless length $_[0] >= 5; my ( $code, $len ) = unpack( "CN", $_[0] ); last unless length $_[0] >= 5 + $len; substr( $_[0], 0, 5, "" ); my $payload = substr( $_[0], 0, $len, "" ); my $message = Tangence::Message->new( $self, $code, $payload ); if( $code < 0x80 ) { push @{ $self->{request_queue} }, undef; my $token = \$self->{request_queue}[-1]; if( !$self->minor_version and $code != MSG_INIT ) { $self->respondERROR( $token, "Cannot accept any message except MSG_INIT before MSG_INIT" ); next; } if( my $method = $REQ_METHOD{$code} ) { if( $self->can( $method ) ) { $self->$method( $token, $message ); } else { $self->respondERROR( $token, sprintf( "Cannot respond to request code 0x%02x", $code ) ); } } else { $self->respondERROR( $token, sprintf( "Unrecognised request code 0x%02x", $code ) ); } } else { my $on_response = shift @{ $self->{responder_queue} }; $on_response->( $message ); } } } sub object_destroyed ( $self, $obj, $startsub, $donesub ) { $startsub->(); my $objid = $obj->id; delete $self->peer_hasobj->{$objid}; $self->request( request => Tangence::Message->new( $self, MSG_DESTROY ) ->pack_int( $objid ), on_response => sub { my ( $message ) = @_; my $code = $message->code; if( $code == MSG_OK ) { $donesub->(); } elsif( $code == MSG_ERROR ) { my $msg = $message->unpack_str(); print STDERR "Cannot get connection $self to destroy object $objid - error $msg\n"; } else { print STDERR "Cannot get connection $self to destroy object $objid - code $code\n"; } }, ); } =head2 request $stream->request( %args ) Serialises a message object to pass to the C method, then enqueues a response handler to be invoked when a reply arrives. Takes the following named arguments: =over 8 =item request => Tangence::Message The message body =item on_response => CODE CODE reference to the callback to be invoked when a response to the message is received. It will be passed the response message: $on_response->( $message ) =back =head2 request (non-void) $response = $stream->request( request => $request )->get When called in non-void context, this method returns a L that will yield the response instead. In this case it should not be given an C callback. In this form, a C response will automatically turn into a failed Future; the subsequent C or C code will not have to handle this case. =cut sub request ( $self, %args ) { my $request = $args{request} or croak "Expected 'request'"; my $f; my $on_response; if( defined wantarray ) { $args{on_response} and croak "TODO: Can't take 'on_response' and return a Future"; $f = $self->new_future; $on_response = sub { my ( $response ) = @_; if( $response->code == MSG_ERROR ) { $f->fail( $response->unpack_str(), tangence => ); } else { $f->done( $response ); } }; } else { $on_response = $args{on_response} or croak "Expected 'on_response'"; } push @{ $self->{responder_queue} }, $on_response; my $payload = $request->payload; $self->tangence_write( pack "CNa*", $request->code, length($payload), $payload ); return $f; } =head2 respond $stream->respond( $token, $message ) Serialises a message object to be sent to the C method. The C<$token> value that was passed to the C method ensures that it is sent at the correct position in the stream, to allow the peer to pair it with the corresponding request. =cut sub respond ( $self, $token, $message ) { my $payload = $message->payload; my $response = pack "CNa*", $message->code, length($payload), $payload; $$token = $response; while( defined $self->{request_queue}[0] ) { $self->tangence_write( shift @{ $self->{request_queue} } ); } } sub respondERROR ( $self, $token, $string ) { $self->respond( $token, Tangence::Message->new( $self, MSG_ERROR ) ->pack_str( $string ) ); } =head2 minor_version $ver = $stream->minor_version Returns the minor version negotiated by the C / C initial message handshake. =cut sub minor_version { my $self = shift; ( $self->{tangence_minor_version} ) = @_ if @_; return $self->{tangence_minor_version} // 0; } # Some (internal) methods that control new protocol features # wire protocol uses typed smash data sub _ver_can_typed_smash { shift->minor_version >= 4 } # wire protocol understands FLOAT* types sub _ver_can_num_float { shift->minor_version >= 4 } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Struct.pm000444001750001750 630614174566136 16203 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Struct 0.28; class Tangence::Struct isa Tangence::Meta::Struct; use Carp; use Tangence::Type; use Tangence::Meta::Field; our %STRUCTS_BY_NAME; our %STRUCTS_BY_PERLNAME; sub make ( $class, %args ) { my $name = $args{name}; return $STRUCTS_BY_NAME{$name} //= $class->new( %args ); } sub declare ( $class, $perlname, %args ) { ( my $name = $perlname ) =~ s{::}{.}g; $name = $args{name} if $args{name}; my @fields; for( $_ = 0; $_ < @{$args{fields}}; $_ += 2 ) { push @fields, Tangence::Meta::Field->new( name => $args{fields}[$_], type => Tangence::Type->make_from_sig( $args{fields}[$_+1] ), ); } my $self = $class->make( name => $name ); $self->_set_perlname( $perlname ); $self->define( fields => \@fields, ); $STRUCTS_BY_PERLNAME{$perlname} = $self; return $self; } sub declare_builtin { my $class = shift; my $self = $class->declare( @_ ); $Tangence::Stream::ALWAYS_PEER_HASSTRUCT{$self->perlname} = [ $self, my $structid = ++$Tangence::Struct::BUILTIN_STRUCTIDS ]; $Tangence::Stream::BUILTIN_ID2STRUCT{$structid} = $self; return $self; } sub define { my $self = shift; $self->SUPER::define( @_ ); my $class = $self->perlname; my @fieldnames = map { $_->name } $self->fields; # Now construct the actual perl package my %subs = ( new => sub ( $class, %args ) { exists $args{$_} or croak "$class is missing $_" for @fieldnames; bless [ @args{@fieldnames} ], $class; }, ); $subs{$fieldnames[$_]} = do { my $i = $_; sub { shift->[$i] } } for 0 .. $#fieldnames; no strict 'refs'; foreach my $name ( keys %subs ) { next if defined &{"${class}::${name}"}; *{"${class}::${name}"} = $subs{$name}; } } sub for_name ( $class, $name ) { return $STRUCTS_BY_NAME{$name} // croak "Unknown Tangence::Struct for '$name'"; } sub for_perlname ( $class, $perlname ) { return $STRUCTS_BY_PERLNAME{$perlname} // croak "Unknown Tangence::Struct for '$perlname'"; } has $perlname :writer(_set_perlname); method perlname { return $perlname if defined $perlname; ( $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14 return $perlname; } Tangence::Struct->declare_builtin( "Tangence::Struct::Class", name => "Tangence.Class", fields => [ methods => "dict(any)", events => "dict(any)", properties => "dict(any)", superclasses => "list(str)", ], ); Tangence::Struct->declare_builtin( "Tangence::Struct::Method", name => "Tangence.Method", fields => [ arguments => "list(str)", returns => "str", ], ); Tangence::Struct->declare_builtin( "Tangence::Struct::Event", name => "Tangence.Event", fields => [ arguments => "list(str)", ], ); Tangence::Struct->declare_builtin( "Tangence::Struct::Property", name => "Tangence.Property", fields => [ dimension => "int", type => "str", smashed => "bool", ], ); 0x55AA; Tangence-0.28/lib/Tangence/Type.pm000444001750001750 4510214174566136 15655 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2022 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Type 0.28; class Tangence::Type isa Tangence::Meta::Type; =head1 NAME C - represent a C value type =head1 DESCRIPTION Objects in this class represent individual types that are sent over the wire in L messages. This is a subclass of L which provides additional methods that may be useful in server or client implementations. =cut =head1 CONSTRUCTOR =head2 make $type = Tangence::Type->make( $primitive_sig ) Returns an instance to represent a primitive type of the given signature. $type = Tangence::Type->make( list => $member_type ) $type = Tangence::Type->make( dict => $member_type ) Returns an instance to represent a list or dict aggregation containing members of the given type. =cut sub make { # Subtle trickery is at work here # Invoke our own superclass constructor, but pretend to be some higher # subclass that's appropriate shift; if( @_ == 1 ) { my ( $type ) = @_; my $class = "Tangence::Type::Primitive::$type"; $class->can( "make" ) or die "TODO: Need $class"; return $class->SUPER::make( $type ); } elsif( $_[0] eq "list" ) { shift; return Tangence::Type::List->SUPER::make( list => @_ ); } elsif( $_[0] eq "dict" ) { shift; return Tangence::Type::Dict->SUPER::make( dict => @_ ); } else { die "TODO: Not sure how to make a Tangence::Type->make( @_ )"; } } =head1 METHODS =head2 default_value $value = $type->default_value Returns a value suitable to use as an initial value for object properties. =head2 pack_value $type->pack_value( $message, $value ) Appends a value of this type to the end of a L. =head2 unpack_value $value = $type->unpack_value( $message ) Removes a value of this type from the start of a L. =cut class Tangence::Type::List isa Tangence::Type { use Carp; use Tangence::Constants; method default_value { [] } method pack_value ( $message, $value ) { ref $value eq "ARRAY" or croak "Cannot pack a list from non-ARRAY reference"; $message->_pack_leader( DATA_LIST, scalar @$value ); my $member_type = $self->member_type; $member_type->pack_value( $message, $_ ) for @$value; } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); $type == DATA_LIST or croak "Expected to unpack a list but did not find one"; my $member_type = $self->member_type; my @values; foreach ( 1 .. $num ) { push @values, $member_type->unpack_value( $message ); } return \@values; } } class Tangence::Type::Dict isa Tangence::Type { use Carp; use Tangence::Constants; method default_value { {} } method pack_value ( $message, $value ) { ref $value eq "HASH" or croak "Cannot pack a dict from non-HASH reference"; my @keys = keys %$value; @keys = sort @keys if $Tangence::Message::SORT_HASH_KEYS; $message->_pack_leader( DATA_DICT, scalar @keys ); my $member_type = $self->member_type; $message->pack_str( $_ ), $member_type->pack_value( $message, $value->{$_} ) for @keys; } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); $type == DATA_DICT or croak "Expected to unpack a dict but did not find one"; my $member_type = $self->member_type; my %values; foreach ( 1 .. $num ) { my $key = $message->unpack_str(); $values{$key} = $member_type->unpack_value( $message ); } return \%values; } } class Tangence::Type::Primitive::bool isa Tangence::Type { use Carp; use Tangence::Constants; method default_value { "" } method pack_value ( $message, $value ) { $message->_pack_leader( DATA_NUMBER, $value ? DATANUM_BOOLTRUE : DATANUM_BOOLFALSE ); } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); $type == DATA_NUMBER or croak "Expected to unpack a number(bool) but did not find one"; $num == DATANUM_BOOLFALSE and return !!0; $num == DATANUM_BOOLTRUE and return !!1; croak "Expected to find a DATANUM_BOOL subtype but got $num"; } } class Tangence::Type::Primitive::_integral isa Tangence::Type { use Carp; use Tangence::Constants; use constant SUBTYPE => undef; method default_value { 0 } my %format = ( DATANUM_UINT8, [ "C", 1 ], DATANUM_SINT8, [ "c", 1 ], DATANUM_UINT16, [ "S>", 2 ], DATANUM_SINT16, [ "s>", 2 ], DATANUM_UINT32, [ "L>", 4 ], DATANUM_SINT32, [ "l>", 4 ], DATANUM_UINT64, [ "Q>", 8 ], DATANUM_SINT64, [ "q>", 8 ], ); sub _best_int_type_for ( $n ) { if( $n < 0 ) { return DATANUM_SINT8 if $n >= -0x80; return DATANUM_SINT16 if $n >= -0x8000; return DATANUM_SINT32 if $n >= -0x80000000; return DATANUM_SINT64; } return DATANUM_UINT8 if $n <= 0xff; return DATANUM_UINT16 if $n <= 0xffff; return DATANUM_UINT32 if $n <= 0xffffffff; return DATANUM_UINT64; } method pack_value ( $message, $value ) { defined $value or croak "cannot pack_int(undef)"; ref $value and croak "$value is not a number"; $value == $value or croak "cannot pack_int(NaN)"; $value == "+Inf" || $value == "-Inf" and croak "cannot pack_int(Inf)"; my $subtype = $self->SUBTYPE || _best_int_type_for( $value ); $message->_pack_leader( DATA_NUMBER, $subtype ); $message->_pack( pack( $format{$subtype}[0], $value ) ); } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; exists $format{$num} or croak "Expected an integer subtype but got $num"; if( my $subtype = $self->SUBTYPE ) { $subtype == $num or croak "Expected integer subtype $subtype, got $num"; } my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); return $n; } } class Tangence::Type::Primitive::u8 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_UINT8; } class Tangence::Type::Primitive::s8 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_SINT8; } class Tangence::Type::Primitive::u16 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_UINT16; } class Tangence::Type::Primitive::s16 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_SINT16; } class Tangence::Type::Primitive::u32 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_UINT32; } class Tangence::Type::Primitive::s32 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_SINT32; } class Tangence::Type::Primitive::u64 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_UINT64; } class Tangence::Type::Primitive::s64 isa Tangence::Type::Primitive::_integral { use constant SUBTYPE => Tangence::Constants::DATANUM_SINT64; } class Tangence::Type::Primitive::int isa Tangence::Type::Primitive::_integral { # empty } class Tangence::Type::Primitive::float isa Tangence::Type { use Carp; use Tangence::Constants; my $TYPE_FLOAT16 = Tangence::Type->make( 'float16' ); use constant SUBTYPE => undef; method default_value { 0.0 } my %format = ( # pack, bytes, NaN DATANUM_FLOAT32, [ "f>", 4, "\x7f\xc0\x00\x00" ], DATANUM_FLOAT64, [ "d>", 8, "\x7f\xf8\x00\x00\x00\x00\x00\x00" ], ); sub _best_type_for ( $value ) { # Unpack as 64bit float and see if it's within limits my $float64BIN = pack "d>", $value; # float64 == 1 / 11 / 52 my $exp64 = ( unpack "L>", $float64BIN & "\x7f\xf0\x00\x00" ) >> (52-32); # Zero is smallest return DATANUM_FLOAT16 if $exp64 == 0; # De-bias $exp64 -= 1023; # Special values might as well be float16 return DATANUM_FLOAT16 if $exp64 == 1024; # Smaller types are OK if the exponent will fit and there's no loss of # mantissa precision return DATANUM_FLOAT16 if abs($exp64) < 15 && ($float64BIN & "\x00\x00\x03\xff\xff\xff\xff\xff") eq "\x00"x8; return DATANUM_FLOAT32 if abs($exp64) < 127 && ($float64BIN & "\x00\x00\x00\x00\x1f\xff\xff\xff") eq "\x00"x8; return DATANUM_FLOAT64; } method pack_value ( $message, $value ) { defined $value or croak "cannot pack undef as float"; ref $value and croak "$value is not a number"; my $subtype = $self->SUBTYPE || _best_type_for( $value ); return $TYPE_FLOAT16->pack_value( $message, $value ) if $subtype == DATANUM_FLOAT16; $message->_pack_leader( DATA_NUMBER, $subtype ); $message->_pack( $value == $value ? pack( $format{$subtype}[0], $value ) : $format{$subtype}[2] ); } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader( "peek" ); $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; exists $format{$num} or $num == DATANUM_FLOAT16 or croak "Expected a float subtype but got $num"; if( my $subtype = $self->SUBTYPE ) { $subtype == $num or croak "Expected float subtype $subtype, got $num"; } return $TYPE_FLOAT16->unpack_value( $message ) if $num == DATANUM_FLOAT16; $message->_unpack_leader; # no-peek my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); return $n; } } class Tangence::Type::Primitive::float16 isa Tangence::Type::Primitive::float { use Carp; use Tangence::Constants; use constant SUBTYPE => DATANUM_FLOAT16; # TODO: This code doesn't correctly cope with Inf, -Inf or NaN method pack_value ( $message, $value ) { defined $value or croak "cannot pack undef as float"; ref $value and croak "$value is not a number"; my $float32 = unpack( "N", pack "f>", $value ); # float32 == 1 / 8 / 23 my $sign = ( $float32 & 0x80000000 ) >> 31; my $exp = ( ( $float32 & 0x7f800000 ) >> 23 ) - 127; my $mant32 = ( $float32 & 0x007fffff ); # float16 == 1 / 5 / 10 my $mant16; if( $exp == 128 ) { # special value - Inf or NaN $exp = 16; $mant16 = $mant32 ? (1 << 9) : 0; $sign = 0 if $mant16; } elsif( $exp > 15 ) { # Too large - become Inf $exp = 16; $mant16 = 0; } elsif( $exp > -15 ) { $mant16 = $mant32 >> 13; } else { # zero or subnormal - become zero $exp = -15; $mant16 = 0; } my $float16 = $sign << 15 | ( $exp + 15 ) << 10 | $mant16; $message->_pack_leader( DATA_NUMBER, DATANUM_FLOAT16 ); $message->_pack( pack "n", $float16 ); } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader; $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; $num == DATANUM_FLOAT16 or croak "Expected to unpack a float16 but found $num"; my $float16 = unpack "n", $message->_unpack( 2 ); # float16 == 1 / 5 / 10 my $sign = ( $float16 & 0x8000 ) >> 15; my $exp = ( ( $float16 & 0x7c00 ) >> 10 ) - 15; my $mant16 = ( $float16 & 0x03ff ); # float32 == 1 / 8 / 23 my $mant32; if( $exp == 16 ) { # special value - Inf or NaN $exp = 128; $mant32 = $mant16 ? (1 << 22) : 0; } elsif( $exp > -15 ) { $mant32 = $mant16 << 13; } else { # zero $exp = -127; $mant32 = 0; } my $float32 = $sign << 31 | ( $exp + 127 ) << 23 | $mant32; return unpack( "f>", pack "N", $float32 ); } } class Tangence::Type::Primitive::float32 isa Tangence::Type::Primitive::float { use Tangence::Constants; use constant SUBTYPE => DATANUM_FLOAT32; } class Tangence::Type::Primitive::float64 isa Tangence::Type::Primitive::float { use Tangence::Constants; use constant SUBTYPE => DATANUM_FLOAT64; } class Tangence::Type::Primitive::str isa Tangence::Type { use Carp; use Encode qw( encode_utf8 decode_utf8 ); use Tangence::Constants; method default_value { "" } method pack_value ( $message, $value ) { defined $value or croak "cannot pack_str(undef)"; ref $value and croak "$value is not a string"; my $octets = encode_utf8( $value ); $message->_pack_leader( DATA_STRING, length($octets) ); $message->_pack( $octets ); } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); $type == DATA_STRING or croak "Expected to unpack a string but did not find one"; my $octets = $message->_unpack( $num ); return decode_utf8( $octets ); } } class Tangence::Type::Primitive::obj isa Tangence::Type { use Carp; use Scalar::Util qw( blessed ); use Tangence::Constants; method default_value { undef } method pack_value ( $message, $value ) { my $stream = $message->stream; if( !defined $value ) { $message->_pack_leader( DATA_OBJECT, 0 ); } elsif( blessed $value and $value->isa( "Tangence::Object" ) ) { my $id = $value->id; my $preamble = ""; $value->{destroyed} and croak "Cannot pack destroyed object $value"; $message->packmeta_construct( $value ) unless $stream->peer_hasobj->{$id}; $message->_pack_leader( DATA_OBJECT, 4 ); $message->_pack( pack( "N", $id ) ); } elsif( blessed $value and $value->isa( "Tangence::ObjectProxy" ) ) { $message->_pack_leader( DATA_OBJECT, 4 ); $message->_pack( pack( "N", $value->id ) ); } else { croak "Do not know how to pack a " . ref($value); } } method unpack_value ( $message ) { my ( $type, $num ) = $message->_unpack_leader(); my $stream = $message->stream; $type == DATA_OBJECT or croak "Expected to unpack an object but did not find one"; return undef unless $num; if( $num == 4 ) { my ( $id ) = unpack( "N", $message->_unpack( 4 ) ); return $stream->get_by_id( $id ); } else { croak "Unexpected number of bits to encode an OBJECT"; } } } class Tangence::Type::Primitive::any isa Tangence::Type { use Carp; use Scalar::Util qw( blessed ); use Tangence::Constants; use Syntax::Keyword::Match; no if $] >= 5.035008, warnings => "experimental::builtin"; use constant HAVE_ISBOOL => defined &builtin::isbool; my $TYPE_BOOL = Tangence::Type->make( 'bool' ); my $TYPE_INT = Tangence::Type->make( 'int' ); my $TYPE_FLOAT = Tangence::Type->make( 'float' ); my $TYPE_STR = Tangence::Type->make( 'str' ); my $TYPE_OBJ = Tangence::Type->make( 'obj' ); my $TYPE_ANY = Tangence::Type->make( 'any' ); my $TYPE_LIST_ANY = Tangence::Type->make( list => $TYPE_ANY ); my $TYPE_DICT_ANY = Tangence::Type->make( dict => $TYPE_ANY ); method default_value { undef } method pack_value ( $message, $value ) { if( !defined $value ) { $TYPE_OBJ->pack_value( $message, undef ); } elsif( !ref $value ) { no warnings 'numeric'; my $is_numeric = do { my $tmp = $value; # use X^X operator to distinguish actual numbers from strings # If $tmp contains any non-ASCII bytes the it's definitely not a # decimal representation of a number $tmp =~ m/^[[:ascii:]]+$/ and ( $value ^ $value ) eq "0" }; if( HAVE_ISBOOL && builtin::isbool($value) ) { $TYPE_BOOL->pack_value( $message, $value ); } # test for integers, but exclude NaN elsif( int($value) eq $value and $value == $value ) { $TYPE_INT->pack_value( $message, $value ); } elsif( $message->stream->_ver_can_num_float and $is_numeric ) { $TYPE_FLOAT->pack_value( $message, $value ); } else { $TYPE_STR->pack_value( $message, $value ); } } elsif( blessed $value and $value->isa( "Tangence::Object" ) || $value->isa( "Tangence::ObjectProxy" ) ) { $TYPE_OBJ->pack_value( $message, $value ); } elsif( my $struct = eval { Tangence::Struct->for_perlname( ref $value ) } ) { $message->pack_record( $value, $struct ); } elsif( ref $value eq "ARRAY" ) { $TYPE_LIST_ANY->pack_value( $message, $value ); } elsif( ref $value eq "HASH" ) { $TYPE_DICT_ANY->pack_value( $message, $value ); } else { croak "Do not know how to pack a " . ref($value); } } method unpack_value ( $message ) { my $type = $message->_peek_leader_type(); match( $type : == ) { case( DATA_NUMBER ) { my ( undef, $num ) = $message->_unpack_leader( "peek" ); if( $num >= DATANUM_BOOLFALSE and $num <= DATANUM_BOOLTRUE ) { return $TYPE_BOOL->unpack_value( $message ); } elsif( $num >= DATANUM_UINT8 and $num <= DATANUM_SINT64 ) { return $TYPE_INT->unpack_value( $message ); } elsif( $num >= DATANUM_FLOAT16 and $num <= DATANUM_FLOAT64 ) { return $TYPE_FLOAT->unpack_value( $message ); } else { croak "Do not know how to unpack DATA_NUMBER subtype $num"; } } case( DATA_STRING ) { return $TYPE_STR->unpack_value( $message ); } case( DATA_OBJECT ) { return $TYPE_OBJ->unpack_value( $message ); } case( DATA_LIST ) { return $TYPE_LIST_ANY->unpack_value( $message ); } case( DATA_DICT ) { return $TYPE_DICT_ANY->unpack_value( $message ); } case( DATA_RECORD ) { return $message->unpack_record( undef ); } default { croak "Do not know how to unpack record of type $type"; } } } } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Types.pm000444001750001750 176014174566136 16022 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk package Tangence::Types 0.28; use v5.26; use warnings; use Exporter 'import'; our @EXPORT = qw( TYPE_BOOL TYPE_U8 TYPE_INT TYPE_STR TYPE_OBJ TYPE_ANY TYPE_LIST_STR TYPE_LIST_ANY TYPE_DICT_ANY ); use Tangence::Type; use constant TYPE_BOOL => Tangence::Type->make( "bool" ); use constant TYPE_U8 => Tangence::Type->make( "u8" ); use constant TYPE_INT => Tangence::Type->make( "int" ); use constant TYPE_STR => Tangence::Type->make( "str" ); use constant TYPE_OBJ => Tangence::Type->make( "obj" ); use constant TYPE_ANY => Tangence::Type->make( "any" ); use constant TYPE_LIST_STR => Tangence::Type->make( list => TYPE_STR ); use constant TYPE_LIST_ANY => Tangence::Type->make( list => TYPE_ANY ); use constant TYPE_DICT_ANY => Tangence::Type->make( dict => TYPE_ANY ); 0x55AA; Tangence-0.28/lib/Tangence/Compiler000755001750001750 014174566136 15771 5ustar00leoleo000000000000Tangence-0.28/lib/Tangence/Compiler/Parser.pm000444001750001750 2612114174566136 17742 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Compiler::Parser 0.28; class Tangence::Compiler::Parser isa Parser::MGC; use Syntax::Keyword::Dynamically; use Syntax::Keyword::Match; use File::Basename qw( dirname ); use Tangence::Constants; # Parsing is simpler if we treat Package.Name as a simple identifier use constant pattern_ident => qr/[[:alnum:]_][\w.]*/; use constant pattern_comment => qr/#.*\n/; =head1 NAME C - parse C interface definition files =head1 DESCRIPTION This subclass of L parses a L interface definition and returns a metadata tree. =cut =head1 GRAMMAR The top level of an interface definition file contains C directives and C and C definitions. =head2 include An C directive imports the definitions from another file, named relative to the current file. include "filename.tan" =head2 class A C definition defines the set of methods, events and properties defined by a named class. class N { ... } The contents of the class block will be a list of C, C, C and C declarations. =head2 struct A C definition defines the list of fields contained within a named structure type. struct N { ... } The contents of the struct block will be a list of C declarations. =cut has $_package; # Parser::MGC version 0.20 adds this method. Before then, this workaround is # known to be safe if( $Parser::MGC::VERSION < 0.20 ) { *filename = sub ( $self ) { $self->{filename} }; } method parse { dynamically $_package = \my %package; while( !$self->at_eos ) { match( $self->token_kw(qw( class struct include )) : eq ) { case( 'class' ) { my $classname = $self->token_ident; exists $package{$classname} and $self->fail( "Already have a class or struct called $classname" ); my $class = $self->make_class( name => $classname ); $package{$classname} = $class; $self->scope_of( '{', sub { $self->parse_classblock( $class ) }, '}' ), } case( 'struct' ) { my $structname = $self->token_ident; exists $package{$structname} and $self->fail( "Already have a class or struct called $structname" ); my $struct = $self->make_struct( name => $structname ); $package{$structname} = $struct; $self->scope_of( '{', sub { $self->parse_structblock( $struct ) }, '}' ), } case( 'include' ) { my $filename = dirname($self->filename) . "/" . $self->token_string; my $subparser = (ref $self)->new; my $included = $subparser->from_file( $filename ); foreach my $classname ( keys %$included ) { exists $package{$classname} and $self->fail( "Cannot include '$filename' as class $classname collides" ); $package{$classname} = $included->{$classname}; } } default { $self->fail( "Expected keyword, found $_" ); } } } return \%package; } =head2 method A C declaration defines one method in the class, giving its name (N) and types of its arguments and and return (T). method N(T, T, ...) -> T; =head2 event An C declaration defines one event raised by the class, giving its name (N) and types of its arguments (T). event N(T, T, ...); =head2 prop A C declaration defines one property supported by the class, giving its name (N), dimension (D) and type (T). It may be declared as a C property. [smashed] prop N = D of T; Scalar properties may omit the C, by supplying just the type [smashed] prop N = T; =head2 isa An C declaration declares a superclass of the class, by its name (C) isa C; =cut method parse_classblock ( $class ) { my %methods; my %events; my %properties; my @superclasses; while( !$self->at_eos ) { match( $_ = $self->token_kw(qw( method event prop smashed isa )) : eq ) { case( 'method' ) { my $methodname = $self->token_ident; exists $methods{$methodname} and $self->fail( "Already have a method called $methodname" ); my $args = $self->parse_arglist; my $ret; $self->maybe( sub { $self->expect( '->' ); $ret = $self->parse_type; } ); $methods{$methodname} = $self->make_method( class => $class, name => $methodname, arguments => $args, ret => $ret, ); } case( 'event' ) { my $eventname = $self->token_ident; exists $events{$eventname} and $self->fail( "Already have an event called $eventname" ); my $args = $self->parse_arglist; $events{$eventname} = $self->make_event( class => $class, name => $eventname, arguments => $args, ); } case( 'smashed' ), case( 'prop' ) { my $smashed = 0; if( $_ eq 'smashed' ) { $smashed = 1; $self->expect( 'prop' ); } my $propname = $self->token_ident; exists $properties{$propname} and $self->fail( "Already have a property called $propname" ); $self->expect( '=' ); my $dim = DIM_SCALAR; $self->maybe( sub { $dim = $self->parse_dim; $self->expect( 'of' ); } ); my $type = $self->parse_type; $properties{$propname} = $self->make_property( class => $class, name => $propname, smashed => $smashed, dimension => $dim, type => $type, ); } case( 'isa' ) { my $supername = $self->token_ident; my $super = $_package->{$supername} or $self->fail( "Unrecognised superclass $supername" ); push @superclasses, $super; } } $self->expect( ';' ); } $class->define( methods => \%methods, events => \%events, properties => \%properties, superclasses => \@superclasses, ); } method parse_arglist { return $self->scope_of( "(", sub { $self->list_of( ",", \&parse_arg ) }, ")", ); } method parse_arg { my $name; my $type = $self->parse_type; $self->maybe( sub { $name = $self->token_ident; } ); return $self->make_argument( name => $name, type => $type ); } method parse_structblock ( $struct ) { my @fields; my %fieldnames; while( !$self->at_eos ) { match( $self->token_kw(qw( field )) : eq ) { case( 'field' ) { my $fieldname = $self->token_ident; exists $fieldnames{$fieldname} and $self->fail( "Already have a field called $fieldname" ); $self->expect( '=' ); my $type = $self->parse_type; push @fields, $self->make_field( name => $fieldname, type => $type, ); $fieldnames{$fieldname}++; } } $self->expect( ';' ); } $struct->define( fields => \@fields, ); } =head2 Types The following basic type names are recognised bool int str obj any s8 s16 s32 s64 u8 u16 u32 u64 Aggregate types may be formed of any type (T) by list(T) dict(T) =cut my @basic_types = qw( bool int s8 s16 s32 s64 u8 u16 u32 u64 float float16 float32 float64 str obj any ); method parse_type { $self->any_of( sub { my $aggregate = $self->token_kw(qw( list dict )); $self->commit; my $membertype = $self->scope_of( "(", \&parse_type, ")" ); return $self->make_type( $aggregate => $membertype ); }, sub { my $typename = $self->token_ident; grep { $_ eq $typename } @basic_types or $self->fail( "'$typename' is not a typename" ); return $self->make_type( $typename ); }, ); } my %dimensions = ( scalar => DIM_SCALAR, hash => DIM_HASH, queue => DIM_QUEUE, array => DIM_ARRAY, objset => DIM_OBJSET, ); method parse_dim { my $dimname = $self->token_kw( keys %dimensions ); return $dimensions{$dimname}; } =head1 SUBCLASS METHODS If this class is subclassed, the following methods may be overridden to customise the behaviour. They allow the subclass to return different objects in the syntax tree. =cut =head2 make_class $class = $parser->make_class( name => $name ) Return a new instance of L to go in a package. The parser will call C on it. =cut method make_class { require Tangence::Meta::Class; return Tangence::Meta::Class->new( @_ ); } =head2 make_struct $struct = $parser->make_struct( name => $name ) Return a new instance of L to go in a package. The parser will call C on it. =cut method make_struct { require Tangence::Meta::Struct; return Tangence::Meta::Struct->new( @_ ); } =head2 make_method $method = $parser->make_method( %args ) =head2 make_event $event = $parser->make_event( %args ) =head2 make_property $property = $parser->make_property( %args ) Return a new instance of L, L or L to go in a class. =cut method make_method { require Tangence::Meta::Method; return Tangence::Meta::Method->new( @_ ); } method make_event { require Tangence::Meta::Event; return Tangence::Meta::Event->new( @_ ); } method make_property { require Tangence::Meta::Property; return Tangence::Meta::Property->new( @_ ); } =head2 make_argument $argument = $parser->make_argument( %args ) Return a new instance of L to use for a method or event argument. =cut method make_argument { require Tangence::Meta::Argument; return Tangence::Meta::Argument->new( @_ ); } =head2 make_field $field = $parser->make_field( %args ) Return a new instance of L to use for a structure type. =cut method make_field { require Tangence::Meta::Field; return Tangence::Meta::Field->new( @_ ); } =head2 make_type $type = $parser->make_type( $primitive_name ) $type = $parser->make_type( $aggregate_name => $member_type ) Return an instance of L representing the given primitive or aggregate type name. An implementation is allowed to use singleton objects and return identical objects for the same primitive name or aggregate and member type. =cut method make_type { require Tangence::Meta::Type; return Tangence::Meta::Type->make( @_ ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta000755001750001750 014174566136 15105 5ustar00leoleo000000000000Tangence-0.28/lib/Tangence/Meta/Argument.pm000444001750001750 232714174566136 17366 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.43; package Tangence::Meta::Argument 0.28; class Tangence::Meta::Argument :strict(params); =head1 NAME C - structure representing one C method or event argument =head1 DESCRIPTION This data structure object stores information about one argument to a L class method or event. Once constructed, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $argument = Tangence::Meta::Argument->new( %args ) Returns a new instance initialised by the given arguments. =over 8 =item name => STRING Name of the argument =item type => STRING Type of the arugment as a L reference =back =cut has $name :reader :param = undef; has $type :reader :param; =head1 ACCESSORS =cut =head2 name $name = $argument->name Returns the name of the class =cut =head2 type $type = $argument->type Return the type as a L reference. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Class.pm000444001750001750 1334014174566136 16666 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.43; package Tangence::Meta::Class 0.28; class Tangence::Meta::Class :strict(params); use Carp; =head1 NAME C - structure representing one C class =head1 DESCRIPTION This data structure object stores information about one L class. Once constructed and defined, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $class = Tangence::Meta::Class->new( name => $name ) Returns a new instance representing the given name. =cut has $name :param :reader; has $defined :reader = 0; has @superclasses; has %methods; has %events; has %properties; =head2 define $class->define( %args ) Provides a definition for the class. =over 8 =item methods => HASH =item events => HASH =item properties => HASH Optional HASH references containing metadata about methods, events and properties, as instances of L, L or L. =item superclasses => ARRAY Optional ARRAY reference containing superclasses as C references. =back =cut method define ( %args ) { $defined and croak "Cannot define $name twice"; $defined++; @superclasses = @{ delete $args{superclasses} // [] }; %methods = %{ delete $args{methods} // {} }; %events = %{ delete $args{events} // {} }; %properties = %{ delete $args{properties} // {} }; } =head1 ACCESSORS =cut =head2 defined $defined = $class->defined Returns true if a definintion for the class has been provided using C. =cut =head2 name $name = $class->name Returns the name of the class =cut =head2 perlname $perlname = $class->perlname Returns the perl name of the class. This will be the Tangence name, with dots replaced by double colons (C<::>). =cut method perlname { ( my $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14 return $perlname; } =head2 direct_superclasses @superclasses = $class->direct_superclasses Return the direct superclasses in a list of C references. =cut method direct_superclasses { $defined or croak "$name is not yet defined"; return @superclasses; } =head2 direct_methods $methods = $class->direct_methods Return the methods that this class directly defines (rather than inheriting from superclasses) as a HASH reference mapping names to L instances. =cut method direct_methods { $defined or croak "$name is not yet defined"; return { %methods }; } =head2 direct_events $events = $class->direct_events Return the events that this class directly defines (rather than inheriting from superclasses) as a HASH reference mapping names to L instances. =cut method direct_events { $defined or croak "$name is not yet defined"; return { %events }; } =head2 direct_properties $properties = $class->direct_properties Return the properties that this class directly defines (rather than inheriting from superclasses) as a HASH reference mapping names to L instances. =cut method direct_properties { $defined or croak "$name is not yet defined"; return { %properties }; } =head1 AGGREGATE ACCESSORS The following accessors inspect the full inheritance tree of this class and all its superclasses =cut =head2 superclasses @superclasses = $class->superclasses Return all the superclasses in a list of unique C references. =cut method superclasses { # This algorithm doesn't have to be particularly good, C3 or whatever. # We're not really forming a search order, mearly uniq'ifying my %seen; return grep { !$seen{$_}++ } map { $_, $_->superclasses } @superclasses; } =head2 methods $methods = $class->methods Return all the methods available to this class as a HASH reference mapping names to L instances. =cut method methods { my %methods; foreach ( $self, $self->superclasses ) { my $m = $_->direct_methods; $methods{$_} ||= $m->{$_} for keys %$m; } return \%methods; } =head2 method $method = $class->method( $name ) Return the named method as a L instance, or C if no such method exists. =cut method method ( $name ) { return $self->methods->{$name}; } =head2 events $events = $class->events Return all the events available to this class as a HASH reference mapping names to L instances. =cut method events { my %events; foreach ( $self, $self->superclasses ) { my $e = $_->direct_events; $events{$_} ||= $e->{$_} for keys %$e; } return \%events; } =head2 event $event = $class->event( $name ) Return the named event as a L instance, or C if no such event exists. =cut method event ( $name ) { return $self->events->{$name}; } =head2 properties $properties = $class->properties Return all the properties available to this class as a HASH reference mapping names to L instances. =cut method properties { my %properties; foreach ( $self, $self->superclasses ) { my $p = $_->direct_properties; $properties{$_} ||= $p->{$_} for keys %$p; } return \%properties; } =head2 property $property = $class->property( $name ) Return the named property as a L instance, or C if no such property exists. =cut method property ( $name ) { return $self->properties->{$name}; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Event.pm000444001750001750 331414174566136 16662 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.51; package Tangence::Meta::Event 0.28; class Tangence::Meta::Event :strict(params); =head1 NAME C - structure representing one C event =head1 DESCRIPTION This data structure object stores information about one L class event. Once constructed, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $event = Tangence::Meta::Event->new( %args ) Returns a new instance initialised by the given arguments. =over 8 =item class => Tangence::Meta::Class Reference to the containing class =item name => STRING Name of the event =item arguments => ARRAY Optional ARRAY reference containing arguments as L references. =back =cut has $class :param :weak :reader; has $name :param :reader; has @arguments; ADJUSTPARAMS ( $params ) { exists $params->{arguments} and @arguments = @{ delete $params->{arguments} }; } =head1 ACCESSORS =cut =head2 class $class = $event->class Returns the class the event is a member of =cut =head2 name $name = $event->name Returns the name of the class =cut =head2 arguments @arguments = $event->arguments Return the arguments in a list of L references. =cut method arguments { @arguments } =head2 argtypes @argtypes = $event->argtypes Return the argument types in a list of strings. =cut method argtypes { return map { $_->type } @arguments; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Field.pm000444001750001750 223114174566136 16621 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Meta::Field 0.28; class Tangence::Meta::Field :strict(params); =head1 NAME C - structure representing one C structure field =head1 DESCRIPTION This data structure object stores information about one field of a L structure. Once constructed, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $field = Tangence::Meta::Field->new( %args ) Returns a new instance initialised by the given fields. =over 8 =item name => STRING Name of the field =item type => STRING Type of the field as a L reference =back =cut has $name :param :reader; has $type :param :reader; =head1 ACCESSORS =cut =head2 name $name = $field->name Returns the name of the field =cut =head2 type $type = $field->type Return the type as a L reference. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Method.pm000444001750001750 403314174566136 17020 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.51; package Tangence::Meta::Method 0.28; class Tangence::Meta::Method :strict(params); =head1 NAME C - structure representing one C method =head1 DESCRIPTION This data structure object stores information about one L class method. Once constructed, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $method = Tangence::Meta::Method->new( %args ) Returns a new instance initialised by the given arguments. =over 8 =item class => Tangence::Meta::Class Reference to the containing class =item name => STRING Name of the method =item arguments => ARRAY Optional ARRAY reference containing arguments as L references. =item ret => STRING Optional string giving the return value type as a L reference =back =cut has $class :param :weak :reader; has $name :param :reader; has @arguments; has $ret :param :reader; ADJUSTPARAMS ( $params ) { exists $params->{arguments} and @arguments = @{ delete $params->{arguments} }; } =head1 ACCESSORS =cut =head2 class $class = $method->class Returns the class the method is a member of =cut =head2 name $name = $method->name Returns the name of the class =cut =head2 arguments @arguments = $method->arguments Return the arguments in a list of L references. =cut method arguments { @arguments } =head2 argtype @argtypes = $method->argtypes Return the argument types in a list of L references. =cut method argtypes { return map { $_->type } @arguments; } =head2 ret $ret = $method->ret Returns the return type as a L reference or C if the method does not return a value. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Property.pm000444001750001750 561114174566136 17427 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.44; package Tangence::Meta::Property 0.28; class Tangence::Meta::Property :strict(params); use Syntax::Keyword::Match; use Tangence::Constants; =head1 NAME C - structure representing one C property =head1 DESCRIPTION This data structure object stores information about one L class property. Once constructed, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $property = Tangence::Meta::Property->new( %args ) Returns a new instance initialised by the given arguments. =over 8 =item class => Tangence::Meta::Class Reference to the containing class =item name => STRING Name of the property =item dimension => INT Dimension of the property, as one of the C constants from L. =item type => STRING The element type as a L reference. =item smashed => BOOL Optional. If true, marks that the property is smashed. =back =cut has $class :param :weak :reader; has $name :param :reader; has $dimension :param :reader; has $type :param :reader; has $smashed :param :reader = 0; =head1 ACCESSORS =cut =head2 class $class = $property->class Returns the class the property is a member of =cut =head2 name $name = $property->name Returns the name of the class =cut =head2 dimension $dimension = $property->dimension Returns the dimension as one of the C constants. =cut =head2 type $type = $property->type Returns the element type as a L reference. =cut =head2 overall_type $type = $property->overall_type Returns the type of the entire collection as a L reference. For scalar types this will be the element type. For dict types this will be a hash of the array type. For array, queue and objset types this will a list of the element type. =cut has $_overall_type; method overall_type { return $_overall_type ||= do { my $type = $self->type; my $dim = $self->dimension; match( $dim : == ) { case( DIM_SCALAR ) { $type; } case( DIM_HASH ) { $self->make_type( dict => $type ); } case( DIM_ARRAY ), case( DIM_QUEUE ), case( DIM_OBJSET ) { $self->make_type( list => $type ); } default { die "Unrecognised dimension $dim for ->overall_type"; } } } } =head2 smashed $smashed = $property->smashed Returns true if the property is smashed. =cut # For subclasses to override if required method make_type { return Tangence::Meta::Type->make( @_ ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Struct.pm000444001750001750 330214174566136 17062 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.43; package Tangence::Meta::Struct 0.28; class Tangence::Meta::Struct :strict(params); use Carp; =head1 NAME C - structure representing one C structure type =head1 DESCRIPTION This data structure stores information about one L structure type. Once constructed and defined, such objects are immutable. =cut =head1 CONSTRUCTOR =cut =head2 new $struct = Tangence::Meta::Struct->new( name => $name ) Returns a new instance representing the given name. =cut has $name :param :reader; has $defined :reader = 0; has @fields; =head2 define $struct->define( %args ) Provides a definition for the structure. =over 8 =item fields => ARRAY ARRAY reference containing metadata about the structure's fields, as instances of L. =back =cut method define ( %args ) { $defined and croak "Cannot define $name twice"; $defined++; @fields = @{ $args{fields} }; } =head1 ACCESSORS =cut =head2 defined $defined = $struct->defined Returns true if a definition of the structure has been provided using C. =cut =head2 name $name = $struct->name Returns the name of the structure =cut =head2 fields @fields = $struct->fields Returns a list of the fields defined on the structure, in their order of definition. =cut method fields { $self->defined or croak $self->name . " is not yet defined"; return @fields; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Meta/Type.pm000444001750001750 605314174566136 16525 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Meta::Type 0.28; class Tangence::Meta::Type :strict(params); use Carp; =head1 NAME C - structure representing one C value type =head1 DESCRIPTION This data structure object represents information about a type, such as a method or event argument, a method return value, or a property element type. Due to their simple contents and immutable nature, these objects may be implemented as singletons. Repeated calls to the constructor method for the same type name will yield the same instance. =cut =head1 CONSTRUCTOR =cut =head2 make $type = Tangence::Meta::Type->make( $primitive ) Returns an instance to represent the given primitive type signature. $type = Tangence::Meta::Type->make( $aggregate => $member_type ) Returns an instance to represent the given aggregation of the given type instance. =cut our %PRIMITIVES; our %LISTS; our %DICTS; sub make { my $class = shift; if( @_ == 1 ) { my ( $sig ) = @_; return $PRIMITIVES{$sig} //= $class->new( member_type => $sig ); } elsif( @_ == 2 and $_[0] eq "list" ) { my ( undef, $membertype ) = @_; return $LISTS{$membertype->sig} //= $class->new( aggregate => "list", member_type => $membertype ); } elsif( @_ == 2 and $_[0] eq "dict" ) { my ( undef, $membertype ) = @_; return $DICTS{$membertype->sig} //= $class->new( aggregate => "dict", member_type => $membertype ); } die "TODO: @_"; } =head2 make _from_sig $type = Tangence::Meta::Type->make_from_sig( $sig ) Parses the given full Tangence type signature and returns an instance to represent it. =cut sub make_from_sig ( $class, $sig ) { $sig =~ m/^list\((.*)\)$/ and return $class->make( list => $class->make_from_sig( $1 ) ); $sig =~ m/^dict\((.*)\)$/ and return $class->make( dict => $class->make_from_sig( $1 ) ); return $class->make( $sig ); } has $aggregate :param :reader = "prim"; has $member_type :param; =head1 ACCESSORS =cut =head2 aggregate $agg = $type->aggregate Returns C<"prim"> for primitive types, or the aggregation name for list and dict aggregate types. =cut =head2 member_type $member_type = $type->member_type Returns the member type for aggregation types. Throws an exception for primitive types. =cut method member_type { die "Cannot return the member type for primitive types" if $aggregate eq "prim"; return $member_type; } =head2 sig $sig = $type->sig Returns the Tangence type signature for the type. =cut method sig { return $self->${\"_sig_for_$aggregate"}(); } method _sig_for_prim { return $member_type; } method _sig_for_list { return "list(" . $member_type->sig . ")"; } method _sig_for_dict { return "dict(" . $member_type->sig . ")"; } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/lib/Tangence/Server000755001750001750 014174566136 15465 5ustar00leoleo000000000000Tangence-0.28/lib/Tangence/Server/Context.pm000444001750001750 201514174566136 17602 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk use v5.26; use Object::Pad 0.41; package Tangence::Server::Context 0.28; class Tangence::Server::Context; use Carp; use Tangence::Constants; has $stream :param :reader; has $token :param; sub BUILDARGS ( $class, $stream, $token ) { return ( stream => $stream, token => $token ); } has $responded; # TODO: Object::Pad probably should do this bit method DESTROY { $responded or croak "$self never responded"; } method respond ( $message ) { $responded and croak "$self has responded once already"; $stream->respond( $token, $message ); $responded = 1; return; } method responderr ( $msg ) { chomp $msg; # In case of simple ->responderr( $@ ); $self->respond( Tangence::Message->new( $stream, MSG_ERROR ) ->pack_str( $msg ) ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Tangence-0.28/t000755001750001750 014174566136 12170 5ustar00leoleo000000000000Tangence-0.28/t/00use.t000444001750001750 70014174566136 13423 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use_ok( "Tangence" ); use_ok( "Tangence::Class" ); use_ok( "Tangence::Client" ); use_ok( "Tangence::Constants" ); use_ok( "Tangence::Message" ); use_ok( "Tangence::Object" ); use_ok( "Tangence::ObjectProxy" ); use_ok( "Tangence::Property" ); use_ok( "Tangence::Registry" ); use_ok( "Tangence::Server" ); use_ok( "Tangence::Server::Context" ); use_ok( "Tangence::Stream" ); done_testing; Tangence-0.28/t/01compiler-parser.t000444001750001750 1467614174566136 16015 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use Test::Identity; use Tangence::Compiler::Parser; use Tangence::Constants; use lib "."; my $parser = Tangence::Compiler::Parser->new; { my $meta = $parser->from_file( "t/Ball.tan" ); is_deeply( [ sort keys %$meta ], [sort qw( t.Colourable t.Ball )], 'keys of t/Ball.tan' ); my $methods; my $events; my $props; my @args; my $colourable = $meta->{'t.Colourable'}; isa_ok( $colourable, "Tangence::Meta::Class", 't.Colourable meta' ); is( $colourable->name, "t.Colourable", 't.Colourable name' ); is( $colourable->perlname, "t::Colourable", 't.Colourable perlname' ); $props = $colourable->direct_properties; is_deeply( [ sort keys %$props ], [qw( colour )], 't.Colourable direct props' ); isa_ok( $props->{colour}, "Tangence::Meta::Property", 't.Colourable prop colour' ); is( $props->{colour}->name, "colour", 't.Colourable prop colour name' ); is( $props->{colour}->dimension, DIM_SCALAR, 't.Colourable prop colour dimension' ); isa_ok( $props->{colour}->type, "Tangence::Meta::Type", 't.Colourable prop colour type' ); is( $props->{colour}->type->sig, "str", 't.Colourable prop colour type sig' ); ok( !$props->{colour}->smashed, 't.Colourable prop colour !smashed' ); is_deeply( [ sort keys %{ $colourable->properties } ], [qw( colour )], 't.Colourable props' ); identical( $colourable->property( "colour" ), $props->{colour}, 't.Colourable ->property' ); my $ball = $meta->{'t.Ball'}; isa_ok( $ball, "Tangence::Meta::Class", 't.Ball meta' ); $methods = $ball->direct_methods; is_deeply( [ sort keys %$methods ], [qw( bounce )], 't.Ball direct methods' ); isa_ok( $methods->{bounce}, "Tangence::Meta::Method", 't.Ball method bounce' ); identical( $methods->{bounce}->class, $ball, 't.Ball method bounce class' ); is( $methods->{bounce}->name, "bounce", 't.Ball method bounce name' ); @args = $methods->{bounce}->arguments; is( scalar @args, 1, 't.Ball method bounce has 1 argument' ); is( $args[0]->name, "howhigh", 't.Ball method bounce arg[0] name' ); isa_ok( $args[0]->type, "Tangence::Meta::Type", 't.Ball method bounce arg[0] type' ); is( $args[0]->type->sig, "str", 't.Ball method bounce arg[0] type sig' ); is_deeply( [ map $_->sig, $methods->{bounce}->argtypes ], [qw( str )], 't.Ball method bounce argtypes sigs' ); isa_ok( $methods->{bounce}->ret, "Tangence::Meta::Type", 't.Ball method bounce ret' ); is( $methods->{bounce}->ret->sig, "str", 't.Ball method bounce ret sig' ); is_deeply( [ sort keys %{ $ball->methods } ], [qw( bounce )], 't.Ball methods' ); identical( $ball->method( "bounce" ), $methods->{bounce}, 't.Ball ->method' ); $events = $ball->direct_events; is_deeply( [ sort keys %$events ], [qw( bounced )], 't.Ball direct events' ); isa_ok( $events->{bounced}, "Tangence::Meta::Event", 't.Ball event bounced' ); identical( $events->{bounced}->class, $ball, 't.Ball event bounced class' ); is( $events->{bounced}->name, "bounced", 't.Ball event bounced name' ); @args = $events->{bounced}->arguments; is( scalar @args, 1, 't.Ball event bounced has 1 argument' ); is( $args[0]->name, "howhigh", 't.Ball event bounced arg[0] name' ); isa_ok( $args[0]->type, "Tangence::Meta::Type", 't.Ball event bounced arg[0] type' ); is( $args[0]->type->sig, "str", 't.Ball event bounced arg[0] type sig' ); is_deeply( [ map $_->sig, $events->{bounced}->argtypes ], [qw( str )], 't.Ball event bounced argtypes sigs' ); is_deeply( [ sort keys %{ $ball->events } ], [qw( bounced )], 't.Ball events' ); identical( $ball->event( "bounced" ), $events->{bounced}, 't.Ball ->event' ); $props = $ball->direct_properties; is_deeply( [ sort keys %$props ], [qw( size )], 't.Ball direct props' ); identical( $props->{size}->class, $ball, 't.Ball prop size class' ); is( $props->{size}->name, "size", 't.Ball prop size name' ); is( $props->{size}->dimension, DIM_SCALAR, 't.Ball prop size dimension' ); isa_ok( $props->{size}->type, "Tangence::Meta::Type", 't.Ball prop size type' ); is( $props->{size}->type->sig, "int", 't.Ball prop size type sig' ); ok( $props->{size}->smashed, 't.Ball prop size smashed' ); is_deeply( [ sort keys %{ $ball->properties } ], [qw( colour size )], 't.Ball props' ); identical( $ball->property( "size" ), $props->{size}, 't.Ball ->property' ); is_deeply( [ map { $_->name } $ball->direct_superclasses ], [qw( t.Colourable )], 't.Ball direct superclasses' ); is_deeply( [ map { $_->name } $ball->superclasses ], [qw( t.Colourable )], 't.Ball superclasses' ); } { my $meta = $parser->from_file( "t/TestObj.tan" ); my $testobj = $meta->{'t.TestObj'}; my $props = $testobj->direct_properties; is( $props->{array}->dimension, DIM_ARRAY, 't.TestObj prop array dimension' ); is( $props->{array}->type->sig, "int", 't.TestObj prop array type sig' ); is( $props->{hash}->dimension, DIM_HASH, 't.TestObj prop hash dimension' ); is( $props->{hash}->type->sig, "int", 't.TestObj prop hash type sig' ); is( $props->{queue}->dimension, DIM_QUEUE, 't.TestObj prop queue dimension' ); is( $props->{queue}->type->sig, "int", 't.TestObj prop queue type sig' ); is( $props->{scalar}->dimension, DIM_SCALAR, 't.TestObj prop scalar dimension' ); is( $props->{scalar}->type->sig, "int", 't.TestObj prop scalar type' ); is( $props->{objset}->dimension, DIM_OBJSET, 't.TestObj prop objset dimension' ); is( $props->{objset}->type->sig, "obj", 't.TestObj prop objset type' ); is( $props->{items}->dimension, DIM_SCALAR, 't.TestObj prop items dimension' ); is( $props->{items}->type->aggregate, "list", 't.TestObj prop items type' ); is( $props->{items}->type->sig, "list(obj)", 't.TestObj prop items type sig' ); my $teststruct = $meta->{"t.TestStruct"}; my @fields = $teststruct->fields; is( $fields[0]->name, "b", 't.TestStruct field b' ); is( $fields[0]->type->sig, "bool", 't.TestStruct field b type sig' ); is( $fields[1]->name, "i", 't.TestStruct field i' ); is( $fields[1]->type->sig, "int", 't.TestStruct field i type sig' ); is( $fields[2]->name, "f", 't.TestStruct field f' ); is( $fields[2]->type->sig, "float", 't.TestStruct field f type sig' ); is( $fields[3]->name, "s", 't.TestStruct field s' ); is( $fields[3]->type->sig, "str", 't.TestStruct field s type sig' ); is( $fields[4]->name, "o", 't.TestStruct field o' ); is( $fields[4]->type->sig, "obj", 't.TestStruct field o type sig' ); } done_testing; Tangence-0.28/t/02registry.t000444001750001750 772114174566136 14533 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use Test::Identity; use Test::Memory::Cycle; use Test::Refcount; use Tangence::Constants; use Tangence::Registry; use Struct::Dumb 0.09; # _forbid_arrayification use lib "."; use t::TestObj; $Tangence::Message::SORT_HASH_KEYS = 1; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); ok( defined $registry, 'defined $registry' ); isa_ok( $registry, "Tangence::Registry", '$registry isa Tangence::Registry' ); isa_ok( $registry, "Tangence::Object" , '$registry isa Tangence::Object' ); is( $registry->id, "0", '$registry->id' ); is( $registry->describe, "Tangence::Registry", '$registry->describe' ); is_deeply( $registry->get_prop_objects, { 0 => 'Tangence::Registry' }, '$registry objects initially has only registry' ); my $cb_self; my $added_object_id; $registry->subscribe_event( object_constructed => sub { ( $cb_self, $added_object_id ) = @_ } ); my $obj = $registry->construct( "t::TestObj", scalar => 12, s_scalar => 34, ); ok( defined $obj, 'defined $obj' ); isa_ok( $obj, "t::TestObj", '$obj isa t::TestObj' ); is_oneref( $obj, '$obj has refcount 1 initially' ); is( $obj->id, 1, '$obj->id' ); is( $obj->registry, $registry, '$obj->registry' ); is_deeply( $registry->get_prop_objects, { 0 => 'Tangence::Registry', 1 => 't::TestObj[scalar=12]' }, '$registry objects now has obj too' ); identical( $cb_self, $registry, '$cb_self is $registry' ); is( $added_object_id, "1", '$added_object_id is 1' ); undef $cb_self; ok( $registry->get_by_id( "1" ) == $obj, '$registry->get_by_id "1"' ); ok( !defined $registry->get_by_id( "2" ), '$registry->get_by_id "2"' ); is( $obj->describe, 't::TestObj[scalar=12]', '$obj->describe' ); # Methods { my $mdef = $obj->can_method( "method" ); isa_ok( $mdef, "Tangence::Meta::Method", '$obj->can_method "method"' ); is( $mdef->name, "method", 'can_method "method" name' ); is_deeply( [ map $_->sig, $mdef->argtypes ], [qw( int str )], 'can_method "method" argtypes' ); is( $mdef->ret->sig, "str", 'can_method "method" ret' ); ok( !$obj->can_method( "fly" ), '$obj->can_method "fly" is undef' ); my $methods = $obj->class->methods; is_deeply( [ sort keys %$methods ], [qw( method noreturn )], '$obj->class->methods yields all' ); } # Events { my $edef = $obj->can_event( "event" ); isa_ok( $edef, "Tangence::Meta::Event", '$obj->can_event "event"' ); is( $edef->name, "event", 'can_event "event" name' ); is_deeply( [ map $_->sig, $edef->argtypes ], [qw( int str )], 'can_event "event" argtypes' ); ok( $obj->can_event( "destroy" ), '$obj->can_event "destroy"' ); ok( !$obj->can_event( "flew" ), '$obj->can_event "flew" is undef' ); my $events = $obj->class->events; is_deeply( [ sort keys %$events ], [qw( destroy event )], '$obj->class->events yields all' ); } # Properties { my $pdef = $obj->can_property( "scalar" ); isa_ok( $pdef, "Tangence::Meta::Property", '$obj->can_property "scalar"' ); is( $pdef->name, "scalar", 'can_property "scalar" name' ); is( $pdef->dimension, DIM_SCALAR, 'can_property "scalar" dimension' ); is( $pdef->type->sig, "int", 'can_property "scalar" type' ); ok( !$obj->can_property( "style" ), '$obj->can_property "style" is undef' ); my $properties = $obj->class->properties; is_deeply( [ sort keys %$properties ], [qw( array hash items objset queue s_array s_scalar scalar )], '$obj->class->properties yields all' ); is_deeply( $obj->smashkeys, [qw( s_array s_scalar )], '$obj->smashkeys' ); } is_oneref( $obj, '$obj has refcount 1 just before unref' ); { no warnings 'redefine'; local *Tangence::Property::Instance::_forbid_arrayification = sub {}; memory_cycle_ok( $obj, '$obj has no memory cycles' ); memory_cycle_ok( $registry, '$registry has no memory cycles' ); } done_testing; Tangence-0.28/t/03properties.t000444001750001750 1511214174566136 15071 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use Test::Identity; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::TestObj; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); # SCALAR is( $obj->get_prop_scalar, "123", 'scalar initially' ); my $cb_self; my $scalar; $obj->watch_property( scalar => on_set => sub { ( $cb_self, $scalar ) = @_ }, ); my $scalar_shadow; $obj->watch_property( scalar => on_updated => sub { $scalar_shadow = $_[1] }, ); is( $scalar_shadow, "123", 'scalar shadow initially' ); $obj->set_prop_scalar( "456" ); is( $obj->get_prop_scalar, "456", 'scalar after set' ); identical( $cb_self, $obj, '$cb_self is $obj' ); is( $scalar, "456", '$scalar after set' ); is( $scalar_shadow, "456", 'scalar shadow finally' ); # HASH is_deeply( $obj->get_prop_hash, { one => 1, two => 2, three => 3 }, 'hash initially' ); my $hash; undef $cb_self; my ( $h_key, $h_value ); $obj->watch_property( hash => on_set => sub { ( $cb_self, $hash ) = @_ }, on_add => sub { ( undef, $h_key, $h_value ) = @_ }, on_del => sub { ( undef, $h_key ) = @_ }, ); my $hash_shadow; $obj->watch_property( hash => on_updated => sub { $hash_shadow = $_[1] }, ); is_deeply( $hash_shadow, { one => 1, two => 2, three => 3 }, 'hash shadow initially' ); $obj->set_prop_hash( { four => 4 } ); is_deeply( $obj->get_prop_hash, { four => 4 }, 'hash after set' ); identical( $cb_self, $obj, '$cb_self is $obj' ); is_deeply( $hash, { four => "4" }, '$hash after set' ); $obj->add_prop_hash( five => 5 ); is_deeply( $obj->get_prop_hash, { four => 4, five => 5 }, 'hash after add' ); is( $h_key, 'five', '$h_key after add' ); is( $h_value, 5, '$h_value after add' ); $obj->add_prop_hash( five => 6 ); is_deeply( $obj->get_prop_hash, { four => 4, five => 6 }, 'hash after add as change' ); is( $h_key, 'five', '$h_key after add as change' ); is( $h_value, 6, '$h_value after add as change' ); $obj->del_prop_hash( 'five' ); is_deeply( $obj->get_prop_hash, { four => 4 }, 'hash after del' ); is( $h_key, 'five', '$h_key after del' ); is_deeply( $hash_shadow, { four => 4 }, 'hash shadow finally' ); # QUEUE is_deeply( $obj->get_prop_queue, [ 1, 2, 3 ], 'queue initially' ); my $queue; undef $cb_self; my ( $q_count, @q_values ); $obj->watch_property( queue => on_set => sub { ( $cb_self, $queue ) = @_ }, on_push => sub { shift; @q_values = @_ }, on_shift => sub { ( undef, $q_count ) = @_ }, ); my $queue_shadow; $obj->watch_property( queue => on_updated => sub { $queue_shadow = $_[1] }, ); is_deeply( $queue_shadow, [ 1, 2, 3 ], 'queue shadow initially' ); $obj->set_prop_queue( [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_queue, [ 4, 5, 6 ], 'queue after set' ); identical( $cb_self, $obj, '$cb_self is $obj' ); is_deeply( $queue, [ 4, 5, 6 ], '$queue after set' ); $obj->push_prop_queue( 7 ); is_deeply( $obj->get_prop_queue, [ 4, 5, 6, 7 ], 'queue after push' ); is_deeply( \@q_values, [ 7 ], '@q_values after push' ); $obj->shift_prop_queue; is_deeply( $obj->get_prop_queue, [ 5, 6, 7 ], 'queue after shift' ); is( $q_count, 1, '$q_count after shift' ); $obj->shift_prop_queue( 2 ); is_deeply( $obj->get_prop_queue, [ 7 ], 'queue after shift(2)' ); is( $q_count, 2, '$q_count after shift(2)' ); is_deeply( $queue_shadow, [ 7 ], 'queue shadow finally' ); # ARRAY is_deeply( $obj->get_prop_array, [ 1, 2, 3 ], 'array initially' ); my $array; undef $cb_self; my ( $a_index, $a_count, @a_values, $a_delta ); $obj->watch_property( array => on_set => sub { ( $cb_self, $array ) = @_ }, on_push => sub { shift; @a_values = @_ }, on_shift => sub { ( undef, $a_count ) = @_ }, on_splice => sub { ( undef, $a_index, $a_count, @a_values ) = @_ }, on_move => sub { ( undef, $a_index, $a_delta ) = @_ }, ); my $array_shadow; $obj->watch_property( array => on_updated => sub { $array_shadow = $_[1] }, ); is_deeply( $array_shadow, [ 1, 2, 3 ], 'array shadow initially' ); $obj->set_prop_array( [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_array, [ 4, 5, 6 ], 'array after set' ); identical( $cb_self, $obj, '$cb_self is $obj' ); is_deeply( $array, [ 4, 5, 6 ], '$array after set' ); $obj->push_prop_array( 7 ); is_deeply( $obj->get_prop_array, [ 4, 5, 6, 7 ], 'array after push' ); is_deeply( \@a_values, [ 7 ], '@a_values after push' ); $obj->shift_prop_array; is_deeply( $obj->get_prop_array, [ 5, 6, 7 ], 'array after shift' ); is( $a_count, 1, '$a_count after shift' ); $obj->shift_prop_array( 2 ); is_deeply( $obj->get_prop_array, [ 7 ], 'array after shift(2)' ); is( $a_count, 2, '$a_count after shift(2)' ); $obj->splice_prop_array( 0, 0, ( 5, 6 ) ); is_deeply( $obj->get_prop_array, [ 5, 6, 7 ], 'array after splice(0,0)' ); is( $a_index, 0, '$a_index after splice(0,0)' ); is( $a_count, 0, '$a_count after splice(0,0)' ); is_deeply( \@a_values, [ 5, 6 ], '@a_values after splice(0,0)' ); $obj->splice_prop_array( 2, 1, () ); is_deeply( $obj->get_prop_array, [ 5, 6 ], 'array after splice(2,1)' ); is( $a_index, 2, '$a_index after splice(2,1)' ); is( $a_count, 1, '$a_count after splice(2,1)' ); is_deeply( \@a_values, [ ], '@a_values after splice(2,1)' ); $obj->move_prop_array( 0, 1 ); is_deeply( $obj->get_prop_array, [ 6, 5 ], 'array after move(+1)' ); is( $a_index, 0, '$a_index after move' ); is( $a_delta, 1, '$a_delta after move' ); $obj->set_prop_array( [ 0 .. 9 ] ); $obj->move_prop_array( 3, 2 ); is_deeply( $obj->get_prop_array, [ 0, 1, 2, 4, 5, 3, 6, 7, 8, 9 ], 'array after move(+2)' ); $obj->move_prop_array( 5, -2 ); is_deeply( $obj->get_prop_array, [ 0 .. 9 ], 'array after move(-2)' ); is_deeply( $array_shadow, [ 0 .. 9 ], 'array shadow finally' ); # OBJSET # Shall have to construct some other TestObj objects to use here, as we can't # put regular ints in is_deeply( $obj->get_prop_objset, [], 'objset initially' ); my $objset; undef $cb_self; my ( $added, $deleted_id ); $obj->watch_property( objset => on_set => sub { ( $cb_self, $objset ) = @_ }, on_add => sub { ( undef, $added ) = @_ }, on_del => sub { ( undef, $deleted_id ) = @_ }, ); my $new = $registry->construct( "t::TestObj" ); $obj->set_prop_objset( { $new->id => $new } ); is_deeply( $obj->get_prop_objset, [ $new ], 'objset after set' ); identical( $cb_self, $obj, '$cb_self is $obj' ); is_deeply( $objset, [ $new ], '$objset after set' ); $obj->del_prop_objset( $new ); is_deeply( $obj->get_prop_objset, [], 'objset after del' ); is( $deleted_id, $new->id, '$deleted_id after del' ); $obj->add_prop_objset( $new ); is_deeply( $obj->get_prop_objset, [ $new ], 'objset after add' ); identical( $added, $new, '$added after add' ); done_testing; Tangence-0.28/t/10message.t000444001750001750 3375414174566136 14333 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use Test::Fatal; use Test::HexString; use Tangence::Message; $Tangence::Message::SORT_HASH_KEYS = 1; use Tangence::Type; sub _make_type { Tangence::Type->make_from_sig( shift ) } use lib "."; use t::Colourable; use Scalar::Util (); use constant HAVE_ISBOOL => defined &builtin::isbool; my $VERSION_MINOR = Tangence::Constants->VERSION_MINOR; package TestStream { # We need a testing stream that declares a version use base qw( Tangence::Stream ); sub minor_version { $VERSION_MINOR } sub new { bless {}, shift } # Stub the methods we don't care about sub _install_watch { } sub make_proxy { } sub get_by_id { my ( $self, $id ) = @_; "OBJPROXY[id=$id]" } } Tangence::Struct->declare( "TestRecord", fields => [ one => "int", two => "str", ], ); sub test_specific { my $name = shift; my %args = @_; my $m = Tangence::Message->new( TestStream->new, undef ); my $pack_method = "pack_$args{type}"; is( $m->$pack_method( $args{data} ), $m, "$pack_method returns \$m for $name" ); is_hexstr( $m->payload, $args{stream}, "$pack_method $name" ); my $unpack_method = "unpack_$args{type}"; is_deeply( $m->$unpack_method(), exists $args{retdata} ? $args{retdata} : $args{data}, "$unpack_method $name" ); is( length $m->payload, 0, "eats all stream for $name" ); } sub test_specific_dies { my $name = shift; my %args = @_; ok( exception { my $m = Tangence::Message->new( TestStream->new, undef ); my $pack_method = "pack_$args{type}"; $m->$pack_method( $args{data} ); }, "pack $name dies" ) if exists $args{data}; ok( exception { my $m = Tangence::Message->new( TestStream->new, undef, $args{stream} ); my $unpack_method = "unpack_$args{type}"; $m->$unpack_method() }, "unpack $name dies" ) if exists $args{stream}; } use Tangence::Registry; use t::Ball; my $registry = Tangence::Registry->new( tanfile => "t/Ball.tan", ); my $ball = $registry->construct( "t::Ball", colour => "red", ); $ball->id == 1 or die "Expected ball->id to be 1"; test_specific "bool f", type => "bool", data => !!0, stream => "\x00"; test_specific "bool t", type => "bool", data => !!1, stream => "\x01"; # So many parts of code would provide undef == false, so we will serialise # undef as false and not care about nullable test_specific "bool undef", type => "bool", data => undef, stream => "\x00", retdata => !!0; test_specific_dies "bool from str", type => "bool", stream => "\x20"; test_specific "int tiny", type => "int", data => 20, stream => "\x02\x14"; test_specific "int -ve tiny", type => "int", data => -30, stream => "\x03\xe2"; test_specific "int", type => "int", data => 0x01234567, stream => "\x06\x01\x23\x45\x67"; test_specific "int -ve", type => "int", data => -0x07654321, stream => "\x07\xf8\x9a\xbc\xdf"; test_specific_dies "int from str", type => "int", stream => "\x20"; test_specific_dies "int from ARRAY", type => "int", data => [], stream => "\x40"; test_specific_dies "int from undef", type => "int", data => undef, stream => "\x80"; test_specific_dies "int from NaN", type => "int", data => "NaN"; test_specific_dies "int from +Inf", type => "int", data => "+Inf"; test_specific "string", type => "str", data => "hello", stream => "\x25hello"; test_specific "long string", type => "str", data => "ABC" x 20, stream => "\x3f\x3c" . ( "ABC" x 20 ); test_specific "marginal string", type => "str", data => "x" x 0x1f, stream => "\x3f\x1f" . ( "x" x 0x1f ); test_specific_dies "string from ARRAY", type => "str", data => [], stream => "\x40"; test_specific_dies "string from undef", type => "str", data => undef, stream => "\x80"; test_specific "record", type => "record", data => TestRecord->new( one => 1, two => 2 ), # DATAMETA_STRUCT stream => "\xe3" . "\x2aTestRecord" . "\x02\1" . "\x42" . "\x23one" . "\x23two" . "\x42" . "\x23int" . "\x23str" . # DATA_RECORD "\xa2" . "\x02\1" . "\x02\1" . "\x212"; sub test_typed { my $name = shift; my %args = @_; my $type = _make_type $args{sig}; my $m = Tangence::Message->new( TestStream->new, undef ); $type->pack_value( $m, $args{data} ); is_hexstr( $m->payload, $args{stream}, "pack typed $name" ); my $value = $type->unpack_value( $m ); my $expect = exists $args{retdata} ? $args{retdata} : $args{data}; if( defined $expect and !ref $expect and $expect =~ m/^-?\d+\.\d+/ ) { # Approximate comparison for floats $_ = sprintf "%.5f", $_ for $expect, $value; } elsif( defined $expect and $expect =~ m/^(?:[+-]inf|nan)$/i ) { # Canonicalise infinities $value = 0+$value; $expect = 0+$expect; } is_deeply( $value, $expect, "\$type->unpack_value $name" ); is( length $m->payload, 0, "eats all stream for $name" ); } sub test_typed_dies { my $name = shift; my %args = @_; my $sig = $args{sig}; my $type = _make_type $sig; ok( exception { my $m = Tangence::Message->new( TestStream->new, undef ); $type->pack_value( $m, $args{data} ); }, "\$type->pack_value for ($sig) $name dies" ) if exists $args{data}; ok( exception { my $m = Tangence::Message->new( TestStream->new, undef, $args{stream} ); $type->unpack_value( $m ) }, "\$type->unpack_value for ($sig) $name dies" ) if exists $args{stream}; } test_typed "bool f", sig => "bool", data => !!0, stream => "\x00"; test_typed "bool t", sig => "bool", data => !!1, stream => "\x01"; test_typed_dies "bool from str", sig => "bool", stream => "\x20"; test_typed "num u8", sig => "u8", data => 10, stream => "\x02\x0a"; test_typed "num s8", sig => "s8", data => 10, stream => "\x03\x0a"; test_typed "num s8 -ve", sig => "s8", data => -10, stream => "\x03\xf6"; test_typed "num s32", sig => "s32", data => 100, stream => "\x07\x00\x00\x00\x64"; test_typed "int tiny", sig => "int", data => 20, stream => "\x02\x14"; test_typed "int -ve tiny", sig => "int", data => -30, stream => "\x03\xe2"; test_typed "int", sig => "int", data => 0x01234567, stream => "\x06\x01\x23\x45\x67"; test_typed "int -ve", sig => "int", data => -0x07654321, stream => "\x07\xf8\x9a\xbc\xdf"; test_typed_dies "int from str", sig => "int", stream => "\x20"; test_typed_dies "int from ARRAY", sig => "int", data => [], stream => "\x40"; test_typed_dies "int from NaN", sig => "int", data => "NaN"; test_typed_dies "int from +Inf", sig => "int", data => "+Inf"; test_typed "float16 zero", sig => "float16", data => 0, stream => "\x10\0\0"; test_typed "float16", sig => "float16", data => 1.25, stream => "\x10\x3d\x00"; test_typed "float16 NaN", sig => "float16", data => "NaN", stream => "\x10\x7e\x00"; test_typed "float16 +Inf", sig => "float16", data => "+Inf", stream => "\x10\x7c\x00"; test_typed "float16 undersize", sig => "float16", data => 1E-12, stream => "\x10\x00\x00", retdata => 0; test_typed "float16 oversize", sig => "float16", data => 1E12, stream => "\x10\x7c\x00", retdata => "+Inf"; test_typed "float32 zero", sig => "float32", data => 0, stream => "\x11\0\0\0\0"; test_typed "float32", sig => "float32", data => 1.25, stream => "\x11\x3f\xa0\x00\x00"; test_typed "float32 NaN", sig => "float32", data => "NaN", stream => "\x11\x7f\xc0\x00\x00"; test_typed "float32 +Inf", sig => "float32", data => "+Inf", stream => "\x11\x7f\x80\x00\x00"; test_typed "float64 zero", sig => "float64", data => 0, stream => "\x12\0\0\0\0\0\0\0\0"; test_typed "float64", sig => "float64", data => 1588.625, stream => "\x12\x40\x98\xd2\x80\x00\x00\x00\x00"; test_typed "float64 NaN", sig => "float64", data => "NaN", stream => "\x12\x7f\xf8\x00\x00\x00\x00\x00\x00"; test_typed "float64 +Inf", sig => "float64", data => "+Inf", stream => "\x12\x7f\xf0\x00\x00\x00\x00\x00\x00"; test_typed "float one", sig => "float", data => 1, stream => "\x10\x3c\x00"; test_typed "float +100", sig => "float", data => 100, stream => "\x10\x56\x40"; test_typed "float +1E8", sig => "float", data => 1E8, stream => "\x11\x4c\xbe\xbc\x20"; test_typed "float +1E20", sig => "float", data => 1E20, stream => "\x12\x44\x15\xaf\x1d\x78\xb5\x8c\x40"; test_typed "float Inf", sig => "float", data => "+Inf", stream => "\x10\x7c\x00"; test_typed "string", sig => "str", data => "hello", stream => "\x25hello"; test_typed_dies "string from ARRAY", sig => "str", data => [], stream => "\x40"; test_typed "list(string)", sig => 'list(str)', data => [ "a", "b", "c" ], stream => "\x43\x21a\x21b\x21c"; test_typed_dies "list(string) from string", sig => 'list(str)', data => "hello", stream => "\x25hello"; test_typed_dies "list(string) from ARRAY(ARRAY)", sig => 'list(str)', data => [ [] ], stream => "\x41\x40"; test_typed "dict(string)", sig => 'dict(str)', data => { one => "one", }, stream => "\x61\x23one\x23one"; test_typed_dies "dict(string) from string", sig => 'dict(str)', data => "hello", stream => "\x25hello"; test_typed_dies "dict(string) from HASH(ARRAY)", sig => 'dict(str)', data => { splot => [] }, stream => "\x61\x65splot\x40"; test_typed "object", sig => "obj", data => $ball, # DATAMETA_CLASS stream => "\xe2" . "\x2ct.Colourable" . "\x02\1" . "\xa4" . "\x02\1" . "\x60" . "\x60" . "\x61" . "\x26colour" . "\xa3" . "\x02\4" . "\x02\1" . "\x23str" . "\x00" . "\x40" . "\x40" . # DATAMETA_CLASS "\xe2" . "\x26t.Ball" . "\x02\2" . "\xa4" . "\x02\1" . "\x61" . "\x26bounce" . "\xa2" . "\x02\2" . "\x41" . "\x23str" . "\x23str" . "\x61" . "\x27bounced" . "\xa1" . "\x02\3" . "\x41" . "\x23str" . "\x61" . "\x24size" . "\xa3" . "\x02\4" . "\x02\1" . "\x23int" . "\x01" . "\x41" . "\x2ct.Colourable" . "\x41" . "\x24size" . # DATAMETA_CONSTRUCT "\xe1" . "\x02\1" . "\x02\2" . "\x41" . "\x02\0" . # DATA_OBJ "\x84" . "\0\0\0\1", retdata => "OBJPROXY[id=1]"; test_typed "any (undef)", sig => "any", data => undef, stream => "\x80"; test_typed "any (bool)", sig => "any", data => !!0, stream => "\x00" if HAVE_ISBOOL; test_typed "any (int)", sig => "any", data => 0x1234, stream => "\x04\x12\x34"; test_typed "any (float)", sig => "any", data => 123.45, stream => "\x12\x40\x5e\xdc\xcc\xcc\xcc\xcc\xcd"; test_typed "any (NaN)", sig => "any", data => "NaN"+0, stream => "\x10\x7e\x00"; test_typed "any (string)", sig => "any", data => "hello", stream => "\x25hello"; test_typed "any (string wide)", sig => "any", data => "\x{263A}", stream => "\x23\xE2\x98\xBA"; test_typed "any (ARRAY empty)", sig => "any", data => [], stream => "\x40"; test_typed "any (ARRAY of string)", sig => "any", data => [qw( a b c )], stream => "\x43\x{21}a\x{21}b\x{21}c"; test_typed "any (ARRAY of 0x25 undefs)", sig => "any", data => [ (undef) x 0x25 ], stream => "\x5f\x25" . ( "\x80" x 0x25 ); test_typed "any (ARRAY of ARRAY)", sig => "any", data => [ [] ], stream => "\x41\x40"; test_typed "any (HASH empty)", sig => "any", data => {}, stream => "\x60"; test_typed "any (HASH of string*1)", sig => "any", data => { key => "value" }, stream => "\x61\x23key\x25value"; test_typed "any (HASH of string*2)", sig => "any", data => { a => "A", b => "B" }, stream => "\x62\x21a\x{21}A\x21b\x{21}B"; test_typed "any (HASH of HASH)", sig => "any", data => { hash => {} }, stream => "\x61\x24hash\x60"; test_typed "any (record)", sig => "any", data => TestRecord->new( one => 3, two => 4 ), # DATAMETA_STRUCT stream => "\xe3" . "\x2aTestRecord" . "\x02\1" . "\x42" . "\x23one" . "\x23two" . "\x42" . "\x23int" . "\x23str" . # DATA_RECORD "\xa2" . "\x02\1" . "\x02\3" . "\x214"; my $m; $m = Tangence::Message->new( 0, undef ); $m->pack_all_sametype( _make_type('int'), 10, 20, 30 ); is_hexstr( $m->payload, "\x02\x0a\x02\x14\x02\x1e", 'pack_all_sametype' ); is_deeply( [ $m->unpack_all_sametype( _make_type('int') ) ], [ 10, 20, 30 ], 'unpack_all_sametype' ); is( length $m->payload, 0, "eats all stream for all_sametype" ); done_testing; Tangence-0.28/t/11stream.t000444001750001750 671214174566136 14155 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Test::HexString; use Tangence::Constants; my @calls; my $written = ""; package Testing::Stream { use base qw( Tangence::Stream ); use Future; sub new { return bless {}, shift; } sub new_future { return Future->new; } sub tangence_write { my $self = shift; $written .= $_[0]; } sub handle_request_EVENT { my $self = shift; my ( $token, $message ) = @_; push @calls, [ $self, $token, $message ]; return 1; } sub minor_version { shift->VERSION_MINOR } } my $stream = Testing::Stream->new(); ok( defined $stream, 'defined $stream' ); isa_ok( $stream, "Tangence::Stream", '$stream isa Tangence::Stream' ); # request Future { my $message = Tangence::Message->new( $stream, MSG_CALL ); $message->pack_int( 1 ); $message->pack_str( "method" ); my $f = $stream->request( request => $message, ); my $expect = "\1" . "\0\0\0\x09" . "\x02" . "\x01" . "\x26" . "method"; is_hexstr( $written, $expect, '$written after initial MSG_CALL' ); $written = ""; my $read = "\x82" . "\0\0\0\x09" . "\x28" . "response"; $stream->tangence_readfrom( $read ); is( length $read, 0, '$read completely consumed from response' ); ok( $f->is_ready, '$f is ready after response' ); my $response = await $f; is( $response->code, MSG_RESULT, '$response->code to initial call' ); is( $response->unpack_str, "response", '$response->unpack_str to initial call' ); } # request Future failure { my $message = Tangence::Message->new( $stream, MSG_CALL ); my $f = $stream->request( request => $message, ); $written = ""; my $read = "\x81" . "\0\0\0\x08" . "\x27" . "failure"; $stream->tangence_readfrom( $read ); is( length $read, 0, '$read completely consumed from response' ); ok( $f->is_ready, '$f is ready after response' ); is( scalar $f->failure, "failure", '$f is a failure' ); } # request on_response { my $message = Tangence::Message->new( $stream, MSG_CALL ); $message->pack_int( 1 ); $message->pack_str( "method" ); my $response; $stream->request( request => $message, on_response => sub { $response = $_[0] }, ); my $expect = "\1" . "\0\0\0\x09" . "\x02" . "\x01" . "\x26" . "method"; is_hexstr( $written, $expect, '$written after initial MSG_CALL' ); $written = ""; my $read = "\x82" . "\0\0\0\x09" . "\x28" . "response"; $stream->tangence_readfrom( $read ); is( length $read, 0, '$read completely consumed from response' ); is( $response->code, MSG_RESULT, '$response->code to initial call' ); is( $response->unpack_str, "response", '$response->unpack_str to initial call' ); } { my $read = "\x04" . "\0\0\0\x08" . "\x02" . "\x01" . "\x25" . "event"; $stream->tangence_readfrom( $read ); is( length $read, 0, '$read completely consumed from event' ); my $c = shift @calls; is( $c->[2]->unpack_int, 1, '$message->unpack_int after MSG_EVENT' ); is( $c->[2]->unpack_str, "event", '$message->unpack_str after MSG_EVENT' ); my $message = Tangence::Message->new( $stream, MSG_OK ); $c->[0]->respond( $c->[1], $message ); my $expect = "\x80" . "\0\0\0\0"; is_hexstr( $written, $expect, '$written after response' ); } done_testing; Tangence-0.28/t/20server.t000444001750001750 1200014174566136 14173 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; use Test::HexString; use Test::Identity; use Test::Refcount; use Tangence::Constants; use Tangence::Registry; use Tangence::Server; $Tangence::Message::SORT_HASH_KEYS = 1; use lib "."; use t::Conversation; use t::TestObj; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); is_oneref( $obj, '$obj has refcount 1 initially' ); package TestServer { use base qw( Tangence::Server ); sub new { return bless { written => "" }, shift; } sub tangence_write { my $self = shift; $self->{written} .= $_[0]; } sub send_message { my $self = shift; my ( $message ) = @_; $self->tangence_readfrom( $message ); length($message) == 0 or die "Server failed to read the whole message"; } sub recv_message { my $self = shift; my $message = $self->{written}; $self->{written} = ""; return $message; } } my $server = TestServer->new(); $server->registry( $registry ); is_oneref( $server, '$server has refcount 1 initially' ); # Initialisation { $server->send_message( $C2S{INIT} ); is_hexstr( $server->recv_message, $S2C{INITED}, 'serverstream initially contains INITED message' ); is( $server->minor_version, 4, '$server->minor_version after MSG_INIT' ); $server->send_message( $C2S{GETROOT} ); is_hexstr( $server->recv_message, $S2C{GETROOT}, 'serverstream contains root object' ); # One here, one in each of two smashed prop watches is_refcount( $obj, 3, '$obj has refcount 3 after MSG_GETROOT' ); is( $server->identity, "testscript", '$server->identity' ); $server->send_message( $C2S{GETREGISTRY} ); is_hexstr( $server->recv_message, $S2C{GETREGISTRY}, 'serverstream contains registry' ); } # Methods { $server->send_message( $C2S{CALL} ); is_hexstr( $server->recv_message, $S2C{CALL}, 'serverstream after response to CALL' ); $server->send_message( $C2S{CALL_NORETURN} ); is_hexstr( $server->recv_message, $S2C{CALL_NORETURN}, 'serverstream after respones to void-returning CALL' ); } # Events { $server->send_message( $C2S{SUBSCRIBE} ); is_hexstr( $server->recv_message, $S2C{SUBSCRIBED}, 'received MSG_SUBSCRIBED response' ); $obj->fire_event( event => 20, "bye" ); is_hexstr( $server->recv_message, $S2C{EVENT}, 'received MSG_EVENT' ); $server->send_message( $MSG_OK ); $server->send_message( $C2S{UNSUBSCRIBE} ); is_hexstr( $server->recv_message, $MSG_OK, 'received MSG_OK response to MSG_UNSUBSCRIBE' ); } # Properties get/set { $server->send_message( $C2S{GETPROP} ); is_hexstr( $server->recv_message, $S2C{GETPROP_123}, 'received property value after MSG_GETPROP' ); $server->send_message( $C2S{GETPROPELEM_HASH} ); is_hexstr( $server->recv_message, $S2C{GETPROPELEM_HASH}, 'received element of hash property after MSG_GETPROPELEM' ); $server->send_message( $C2S{GETPROPELEM_ARRAY} ); is_hexstr( $server->recv_message, $S2C{GETPROPELEM_ARRAY}, 'received element of array property after MSG_GETPROPELEM' ); $server->send_message( $C2S{SETPROP} ); is_hexstr( $server->recv_message, $MSG_OK, 'received OK after MSG_SETPROP' ); is( $obj->get_prop_scalar, 135, '$obj->get_prop_scalar after set_property' ); } # Properties watch { $server->send_message( $C2S{WATCH} ); is_hexstr( $server->recv_message, $S2C{WATCHING}, 'received MSG_WATCHING response' ); $obj->set_prop_scalar( 147 ); is_hexstr( $server->recv_message, $S2C{UPDATE_SCALAR_147}, 'received property MSG_UPDATE notice' ); $server->send_message( $MSG_OK ); $server->send_message( $C2S{UNWATCH} ); is_hexstr( $server->recv_message, $MSG_OK, 'received MSG_OK to MSG_UNWATCH' ); } # Cursors { $server->send_message( $C2S{WATCH_ITER} ); is_hexstr( $server->recv_message, $S2C{WATCHING_ITER}, 'received MSG_WATCHING_ITER response' ); $server->send_message( $C2S{ITER_NEXT_1} ); is_hexstr( $server->recv_message, $S2C{ITER_NEXT_1}, 'result from MSG_ITER_NEXT 1 forward' ); $server->send_message( $C2S{ITER_NEXT_5} ); is_hexstr( $server->recv_message, $S2C{ITER_NEXT_5}, 'result from MSG_ITER_NEXT 5 forward' ); $server->send_message( $C2S{ITER_NEXT_BACK} ); is_hexstr( $server->recv_message, $S2C{ITER_NEXT_BACK}, 'result from MSG_ITER_NEXT 1 backward' ); $server->send_message( $C2S{ITER_DESTROY} ); is_hexstr( $server->recv_message, $MSG_OK, 'received OK to MSG_ITER_DESTROY' ); } # Test object destruction { my $obj_destroyed = 0; $obj->destroy( on_destroyed => sub { $obj_destroyed = 1 } ); is_hexstr( $server->recv_message, $S2C{DESTROY}, 'MSG_DESTROY from server' ); $server->send_message( $MSG_OK ); is( $obj_destroyed, 1, 'object gets destroyed' ); } is_oneref( $server, '$server has refcount 1 before shutdown' ); undef $server; is_oneref( $obj, '$obj has refcount 1 before shutdown' ); is_oneref( $registry, '$registry has refcount 1 before shutdown' ); done_testing; Tangence-0.28/t/21client.t000444001750001750 2270714174566136 14163 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Test::Fatal; use Test::HexString; use Test::Refcount; use Tangence::Constants; use Tangence::Types; use lib "."; use t::Conversation; $Tangence::Message::SORT_HASH_KEYS = 1; package TestClient { use base qw( Tangence::Client ); sub new { my $self = bless { written => "" }, shift; $self->identity( "testscript" ); $self->on_error( sub { die "Test failed early - $_[0]" } ); $self->tangence_connected(); return $self; } sub tangence_write { my $self = shift; $self->{written} .= $_[0]; } sub send_message { my $self = shift; my ( $message ) = @_; $self->tangence_readfrom( $message ); length($message) == 0 or die "Client failed to read the whole message"; } sub recv_message { my $self = shift; my $message = $self->{written}; $self->{written} = ""; return $message; } } my $client = TestClient->new(); # Initialisation { is_hexstr( $client->recv_message, $C2S{INIT}, 'client stream initially contains MSG_INIT' ); $client->send_message( $S2C{INITED} ); is_hexstr( $client->recv_message, $C2S{GETROOT} . $C2S{GETREGISTRY}, 'client stream contains MSG_GETROOT and MSG_GETREGISTRY' ); $client->send_message( $S2C{GETROOT} ); $client->send_message( $S2C{GETREGISTRY} ); ok( defined $client->rootobj, 'client has rootobj' ); ok( defined $client->registry, 'client has registry' ); } my $objproxy = $client->rootobj; my $bagproxy; # Methods { my $mdef = $objproxy->can_method( "method" ); ok( defined $mdef, 'defined $mdef' ); is( $mdef->name, "method", '$mdef->name' ); is_deeply( [ $mdef->argtypes ], [ TYPE_INT, TYPE_STR ], '$mdef->argtypes' ); is( $mdef->ret, TYPE_STR, '$mdef->ret' ); my $f = $objproxy->call_method( method => 10, "hello" ); is_hexstr( $client->recv_message, $C2S{CALL}, 'client stream contains MSG_CALL' ); $client->send_message( $S2C{CALL} ); ok( $f->is_ready, '$f ready after MSG_RESULT' ); is( scalar await $f, "10/hello", 'result of call_method()' ); $f = $objproxy->call_method( noreturn => ); is_hexstr( $client->recv_message, $C2S{CALL_NORETURN}, 'client stream contains MSG_CALL for void-returning method' ); $client->send_message( $S2C{CALL_NORETURN} ); ok( exception { $objproxy->call_method( no_such_method => 123 )->get }, 'Calling no_such_method fails in proxy' ); } # Events { my $edef = $objproxy->can_event( "event" ); ok( defined $edef, 'defined $edef' ); is( $edef->name, "event", '$edef->event' ); is_deeply( [ $edef->argtypes ], [ TYPE_INT, TYPE_STR ], '$edef->argtypes' ); my $event_i; my $event_s; my $f = $objproxy->subscribe_event( "event", on_fire => sub { ( $event_i, $event_s ) = @_; }, ); is_hexstr( $client->recv_message, $C2S{SUBSCRIBE}, 'client stream contains MSG_SUBSCRIBE' ); $client->send_message( $S2C{SUBSCRIBED} ); ok( $f->is_ready, '$f is ready after MSG_SUBSCRIBED' ); $client->send_message( $S2C{EVENT} ); $client->recv_message; # MSG_OK is( $event_i, 20, '$event_i after subscribed event' ); $objproxy->unsubscribe_event( "event" ); is_hexstr( $client->recv_message, $C2S{UNSUBSCRIBE}, 'client stream contains MSG_UNSUBSCRIBE' ); $client->send_message( $MSG_OK ); ok( exception { $objproxy->subscribe_event( "no_such_event", on_fire => sub {}, )->get; }, 'Subscribing to no_such_event fails in proxy' ); } # Properties get/set { my $pdef = $objproxy->can_property( "scalar" ); ok( defined $pdef, 'defined $pdef' ); is( $pdef->name, "scalar", '$pdef->name' ); is( $pdef->dimension, DIM_SCALAR, '$pdef->dimension' ); is( $pdef->type, TYPE_INT, '$pdef->type' ); is( $objproxy->prop( "s_scalar" ), 456, 'Smashed property initially set in proxy' ); my $f = $objproxy->get_property( "scalar" ); is_hexstr( $client->recv_message, $C2S{GETPROP}, 'client stream contains MSG_GETPROP' ); $client->send_message( $S2C{GETPROP_123} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); is( scalar await $f, 123, 'await $f after get_property' ); $f = $objproxy->get_property_element( "hash", "two" ); is_hexstr( $client->recv_message, $C2S{GETPROPELEM_HASH}, 'client stream contains MSG_GETPROPELEM' ); $client->send_message( $S2C{GETPROPELEM_HASH} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); is( scalar await $f, 2, 'await $f after get_property_element hash key' ); $f = $objproxy->get_property_element( "array", 1 ); is_hexstr( $client->recv_message, $C2S{GETPROPELEM_ARRAY}, 'client stream contains MSG_GETPROPELEM' ); $client->send_message( $S2C{GETPROPELEM_ARRAY} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); is( scalar await $f, 2, 'await $f after get_property_element array index' ); $f = $objproxy->set_property( "scalar", 135 ); is_hexstr( $client->recv_message, $C2S{SETPROP}, 'client stream contains MSG_SETPROP' ); $client->send_message( $MSG_OK ); ok( $f->is_ready, '$f is ready after set_property' ); } # Properties watch { my $value; my $f = $objproxy->watch_property( "scalar", on_set => sub { $value = shift }, ); is_hexstr( $client->recv_message, $C2S{WATCH}, 'client stream contains MSG_WATCH' ); $client->send_message( $S2C{WATCHING} ); ok( $f->is_ready, '$f is ready after watch_property' ); $client->send_message( $S2C{UPDATE_SCALAR_147} ); is( $value, 147, '$value after watch_property/set_prop_scalar' ); is_hexstr( $client->recv_message, $MSG_OK, 'client stream contains MSG_OK' ); my $valuechanged = 0; my $secondvalue; $f = $objproxy->watch_property_with_initial( "scalar", on_set => sub { $secondvalue = shift; $valuechanged = 1 }, ); is_hexstr( $client->recv_message, $C2S{GETPROP}, 'client stream contains MSG_GETPROP' ); $client->send_message( $S2C{GETPROP_147} ); is( $secondvalue, 147, '$secondvalue after watch_property with want_initial' ); $client->send_message( $S2C{UPDATE_SCALAR_159} ); is( $value, 159, '$value after second MSG_UPDATE' ); is( $valuechanged, 1, '$valuechanged is true after second MSG_UPDATE' ); is_hexstr( $client->recv_message, $MSG_OK, 'client stream contains MSG_OK' ); $objproxy->unwatch_property( "scalar" ); is_hexstr( $client->recv_message, $C2S{UNWATCH}, 'client stream contains MSG_UNWATCH' ); $client->send_message( $MSG_OK ); ok( exception { $objproxy->get_property( "no_such_property" )->get }, 'Getting no_such_property fails in proxy' ); } # Cursors { my @value; my $f = $objproxy->watch_property_with_cursor( "queue", "first", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, ); is_hexstr( $client->recv_message, $C2S{WATCH_ITER}, 'client stream contains MSG_WATCH_ITER' ); $client->send_message( $S2C{WATCHING_ITER} ); ok( $f->is_ready, '$f is ready after MSG_WATCHING_ITER' ); my ( $cursor, $first_idx, $last_idx ) = await $f; is( $first_idx, 0, '$first_idx after MSG_WATCHING_ITER' ); is( $last_idx, 2, '$last_idx after MSG_WATCHING_ITER' ); $f = $cursor->next_forward; is_hexstr( $client->recv_message, $C2S{ITER_NEXT_1}, 'client stream contains MSG_ITER_NEXT' ); $client->send_message( $S2C{ITER_NEXT_1} ); my ( $idx, @more ) = await $f; is( $idx, 0, 'next_forward starts at element 0' ); is_deeply( \@more, [ 1 ], 'next_forward yielded 1 element' ); undef @more; $f = $cursor->next_forward( 5 ); is_hexstr( $client->recv_message, $C2S{ITER_NEXT_5}, 'client stream contains MSG_ITER_NEXT' ); $client->send_message( $S2C{ITER_NEXT_5} ); ( $idx, @more ) = await $f; is( $idx, 1, 'next_forward starts at element 1' ); is_deeply( \@more, [ 2, 3 ], 'next_forward yielded 2 elements' ); undef @more; $f = $cursor->next_backward; is_hexstr( $client->recv_message, $C2S{ITER_NEXT_BACK}, 'client stream contains MSG_ITER_NEXT' ); $client->send_message( $S2C{ITER_NEXT_BACK} ); ( $idx, @more ) = await $f; is( $idx, 2, 'next_backward starts at element 2' ); is_deeply( \@more, [ 3 ], 'next_forward yielded 1 element' ); undef $f; undef $cursor; is_hexstr( $client->recv_message, $C2S{ITER_DESTROY}, 'client stream contains MSG_ITER_DESTROY' ); $client->send_message( $MSG_OK ); } # Smashed Properties { my $value; my $f = $objproxy->watch_property_with_initial( "s_scalar", on_set => sub { $value = shift }, ); ok( $f->is_ready, 'watch_property on smashed prop is synchronous' ); is( $value, 456, 'watch_property on smashed prop gives initial value' ); undef $value; $client->send_message( $S2C{UPDATE_S_SCALAR_468} ); is_hexstr( $client->recv_message, $MSG_OK, 'client stream contains MSG_OK after smashed prop UPDATE' ); is( $value, 468, 'smashed prop update succeeds' ); } # Test object destruction { my $proxy_destroyed = 0; await $objproxy->subscribe_event( "destroy", on_fire => sub { $proxy_destroyed = 1 }, ); $client->send_message( $S2C{DESTROY} ); is_hexstr( $client->recv_message, $MSG_OK, 'client stream contains MSG_OK after MSG_DESTROY' ); is( $proxy_destroyed, 1, 'proxy gets destroyed' ); } is_oneref( $client, '$client has refcount 1 before shutdown' ); undef $client; is_oneref( $objproxy, '$objproxy has refcount 1 before shutdown' ); done_testing; Tangence-0.28/t/22xlink.t000444001750001750 1336614174566136 14034 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Test::Fatal; use Test::Refcount; use Tangence::Constants; use Tangence::Registry; use Tangence::Server; use Tangence::Client; use Tangence::Types; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my ( $server, $client ) = make_serverclient( $registry ); my $objproxy = $client->rootobj; # Methods { my $mdef = $objproxy->can_method( "method" ); ok( defined $mdef, 'defined $mdef' ); is( $mdef->name, "method", '$mdef->name' ); is_deeply( [ $mdef->argtypes ], [ TYPE_INT, TYPE_STR ], '$mdef->argtypes' ); is( $mdef->ret, TYPE_STR, '$mdef->ret' ); my $f = $objproxy->call_method( method => 10, "hello" ); ok( $f->is_ready, '$f ready after MSG_RESULT' ); is( scalar await $f, "10/hello", 'result of call_method()' ); ok( exception { $objproxy->call_method( no_such_method => 123 )->get }, 'Calling no_such_method fails in proxy' ); } # Events { my $edef = $objproxy->can_event( "event" ); ok( defined $edef, 'defined $edef' ); is( $edef->name, "event", '$edef->event' ); is_deeply( [ $edef->argtypes ], [ TYPE_INT, TYPE_STR ], '$edef->argtypes' ); my $event_i; my $event_s; my $f = $objproxy->subscribe_event( "event", on_fire => sub { ( $event_i, $event_s ) = @_; }, ); ok( $f->is_ready, '$f is ready after subscribe_event' ); $obj->fire_event( event => 20, "bye" ); is( $event_i, 20, '$event_i after subscribed event' ); $objproxy->unsubscribe_event( "event" ); ok( exception { $objproxy->subscribe_event( "no_such_event", on_fire => sub {}, )->get; }, 'Subscribing to no_such_event fails in proxy' ); } # Properties get/set { my $pdef = $objproxy->can_property( "scalar" ); ok( defined $pdef, 'defined $pdef' ); is( $pdef->name, "scalar", '$pdef->name' ); is( $pdef->dimension, DIM_SCALAR, '$pdef->dimension' ); is( $pdef->type, TYPE_INT, '$pdef->type' ); is( $objproxy->prop( "s_scalar" ), 456, 'Smashed property initially set in proxy' ); my $f = $objproxy->get_property( "scalar" ); is( scalar await $f, 123, 'await $f after get_property' ); $f = $objproxy->get_property_element( "hash", "two" ); is( scalar await $f, 2, 'await $f after get_property_element hash key' ); $f = $objproxy->get_property_element( "array", 1 ); is( scalar await $f, 2, 'await $f after get_property_element array index' ); $f = $objproxy->set_property( "scalar", 135 ); is( $obj->get_prop_scalar, 135, '$obj->get_prop_scalar after set_property' ); ok( $f->is_ready, '$f is ready after set_property' ); } # Properties watch { my $value; my $f = $objproxy->watch_property( "scalar", on_set => sub { $value = shift }, ); $obj->set_prop_scalar( 147 ); is( $value, 147, '$value after watch_property/set_prop_scalar' ); my $valuechanged = 0; my $secondvalue; $f = $objproxy->watch_property_with_initial( "scalar", on_set => sub { $secondvalue = shift; $valuechanged = 1 }, ); is( $secondvalue, 147, '$secondvalue after watch_property with want_initial' ); $obj->set_prop_scalar( 159 ); is( $value, 159, '$value after second set_prop_scalar' ); is( $valuechanged, 1, '$valuechanged is true after second set_prop_scalar' ); $objproxy->unwatch_property( "scalar" ); ok( exception { $objproxy->get_property( "no_such_property" )->get }, 'Getting no_such_property fails in proxy' ); } # Cursors { my @value; my $f = $objproxy->watch_property_with_cursor( "queue", "first", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, ); ok( $f->is_ready, '$f is ready after MSG_WATCHING_ITER' ); my ( $cursor, $first_idx, $last_idx ) = await $f; is( $first_idx, 0, '$first_idx after MSG_WATCHING_ITER' ); is( $last_idx, 2, '$last_idx after MSG_WATCHING_ITER' ); my ( $idx, @more ) = await $cursor->next_forward; is( $idx, 0, 'next_forward starts at element 0' ); is_deeply( \@more, [ 1 ], 'next_forward yielded 1 element' ); ( $idx, @more ) = await $cursor->next_forward( 5 ); is( $idx, 1, 'next_forward starts at element 1' ); is_deeply( \@more, [ 2, 3 ], 'next_forward yielded 2 elements' ); ( $idx, @more ) = await $cursor->next_backward; is( $idx, 2, 'next_backward starts at element 2' ); is_deeply( \@more, [ 3 ], 'next_forward yielded 1 element' ); } # Smashed Properties { my $value; my $f = $objproxy->watch_property_with_initial( "s_scalar", on_set => sub { $value = shift }, ); ok( $f->is_ready, 'watch_property on smashed prop is synchronous' ); is( $value, 456, 'watch_property on smashed prop gives initial value' ); undef $value; $obj->set_prop_s_scalar( 468 ); is( $value, 468, 'smashed prop update succeeds' ); } # Test object destruction { my $proxy_destroyed = 0; await $objproxy->subscribe_event( "destroy", on_fire => sub { $proxy_destroyed = 1 }, ); my $obj_destroyed = 0; $obj->destroy( on_destroyed => sub { $obj_destroyed = 1 } ); is( $proxy_destroyed, 1, 'proxy gets destroyed' ); is( $obj_destroyed, 1, 'object gets destroyed' ); } is_oneref( $client, '$client has refcount 1 before shutdown' ); is_oneref( $server, '$server has refcount 1 before shutdown' ); undef $client; undef $server; is_oneref( $obj, '$obj has refcount 1 before shutdown' ); is_oneref( $objproxy, '$objproxy has refcount 1 before shutdown' ); is_oneref( $registry, '$registry has refcount 1 before shutdown' ); done_testing; Tangence-0.28/t/23close.t000444001750001750 233614174566136 13770 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my ( $conn1, $conn2 ) = map { my ( $server, $client ) = make_serverclient( $registry ); my $objproxy = $client->rootobj; my $conn = { server => $server, client => $client, objproxy => $objproxy, }; await $objproxy->watch_property( "scalar", on_set => sub { $conn->{scalar} = shift; }, ); my ( $cursor ) = await $objproxy->watch_property_with_cursor( "queue", "first", on_updated => sub {}, ); $conn } 1 .. 2; $obj->set_prop_scalar( 789 ); is( $conn1->{scalar}, 789, '$scalar from connection 1' ); is( $conn2->{scalar}, 789, '$scalar from connection 2' ); $conn1->{server}->tangence_closed; $conn1->{client}->tangence_closed; $obj->set_prop_scalar( 101112 ); is( $conn1->{scalar}, 789, '$scalar unchanged from (closed) connection 1' ); is( $conn2->{scalar}, 101112, '$scalar from connection 2' ); done_testing; Tangence-0.28/t/30props-cbs.t000444001750001750 1015414174566136 14606 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Test::Memory::Cycle; use Tangence::Constants; use Tangence::Registry; use Struct::Dumb 0.09; # _forbid_arrayification use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; # SCALAR { my $scalar; await $proxy->watch_property_with_initial( "scalar", on_set => sub { $scalar = shift }, ); is( $scalar, "123", 'Initial value from watch_property "scalar"' ); undef $scalar; $obj->set_prop_scalar( "1234" ); is( $scalar, "1234", 'set scalar value' ); my $also_scalar; await $proxy->watch_property_with_initial( "scalar", on_updated => sub { $also_scalar = shift }, ); is( $also_scalar, "1234", 'Can watch_property a second time' ); } # HASH { my $hash; my ( $a_key, $a_value ); my ( $d_key ); await $proxy->watch_property_with_initial( "hash", on_set => sub { $hash = shift }, on_add => sub { ( $a_key, $a_value ) = @_ }, on_del => sub { ( $d_key ) = @_ }, ); is_deeply( $hash, { one => 1, two => 2, three => 3 }, 'Initial value from watch_property "hash"' ); $obj->add_prop_hash( four => 4 ); is( $a_key, 'four', 'add hash key' ); is( $a_value, 4, 'add hash value' ); $obj->del_prop_hash( 'one' ); is( $d_key, 'one', 'del hash key' ); } # QUEUE { my $queue; my ( @p_values ); my ( $sh_count ); my ( $s_index, $s_count, @s_values ); await $proxy->watch_property_with_initial( "queue", on_set => sub { $queue = shift }, on_push => sub { @p_values = @_ }, on_shift => sub { ( $sh_count ) = @_ }, ); $obj->push_prop_queue( 6 ); is_deeply( \@p_values, [ 6 ], 'push queue values' ); $obj->shift_prop_queue( 1 ); is( $sh_count, 1, 'shift queue count' ); } # ARRAY { my $array; my ( @p_values ); my ( $sh_count ); my ( $s_index, $s_count, @s_values ); my ( $m_index, $m_delta ); await $proxy->watch_property_with_initial( "array", on_set => sub { $array = shift }, on_push => sub { @p_values = @_ }, on_shift => sub { ( $sh_count ) = @_ }, on_splice => sub { ( $s_index, $s_count, @s_values ) = @_ }, on_move => sub { ( $m_index, $m_delta ) = @_ }, ); $obj->push_prop_array( 6 ); is_deeply( \@p_values, [ 6 ], 'push array values' ); $obj->shift_prop_array( 1 ); is( $sh_count, 1, 'shift array count' ); $obj->splice_prop_array( 1, 2, ( 7 ) ); is( $s_index, 1, 'splice array index' ); is( $s_count, 2, 'splice array count' ); is_deeply( \@s_values, [ 7 ], 'splice array values' ); $obj->set_prop_array( [ 0 .. 4 ] ); $obj->move_prop_array( 1, 3 ); is( $m_index, 1, 'move array index' ); is( $m_delta, 3, 'move array delta' ); } # OBJSET { my $objset; my $added; my $deleted_id; await $proxy->watch_property_with_initial( "objset", on_set => sub { $objset = shift }, on_add => sub { $added = shift }, on_del => sub { $deleted_id = shift }, ); # Shall have to construct some other TestObj objects to use here, as we can't # put regular ints in my $new = $registry->construct( "t::TestObj" ); is_deeply( $objset, {}, 'Initial value from watch_property "objset"' ); undef $objset; $obj->set_prop_objset( { $new->id => $new } ); is( ref $objset, "HASH", 'set objset value type' ); is_deeply( [ keys %$objset ], [ $new->id ], 'set objset value keys' ); $obj->del_prop_objset( $new ); is( $deleted_id, $new->id, 'del objset deleted_id' ); $obj->add_prop_objset( $new ); is( ref $added, "Tangence::ObjectProxy", 'add objset added' ); } { no warnings 'redefine'; local *Tangence::Property::Instance::_forbid_arrayification = sub {}; memory_cycle_ok( $registry, '$registry has no memory cycles' ); memory_cycle_ok( $obj, '$obj has no memory cycles' ); memory_cycle_ok( $proxy, '$proxy has no memory cycles' ); } done_testing; Tangence-0.28/t/31props-cache.t000444001750001750 715114174566136 15066 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Test::Memory::Cycle; use Tangence::Constants; use Tangence::Registry; use Struct::Dumb 0.09; # _forbid_arrayification use lib "."; use t::TestObj; use t::TestServerClient; ### TODO # This test file relies a lot on weird logic in TestObj. Should probably instead just use # the object's property manip. methods directly ### my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; my $scalar; my $scalar_changed = 0; await $proxy->watch_property_with_initial( "scalar", on_set => sub { $scalar = shift; $scalar_changed = 1 }, ); is( $scalar, "123", 'Initial value from watch_property' ); is( $proxy->prop( "scalar" ), "123", "scalar property cache" ); my $hash_changed = 0; await $proxy->watch_property_with_initial( "hash", on_updated => sub { $hash_changed = 1 }, ); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, three => 3 }, 'hash property cache' ); my $array_changed = 0; await $proxy->watch_property_with_initial( "array", on_updated => sub { $array_changed = 1 }, ); is_deeply( $proxy->prop( "array" ), [ 1, 2, 3 ], 'array property cache' ); $obj->add_number( four => 4 ); $array_changed = 0; is( $proxy->prop( "scalar" ), "1234", "scalar property cache after update" ); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, three => 3, four => 4 }, 'hash property cache after update' ); is_deeply( $proxy->prop( "array" ), [ 1, 2, 3, 4 ], 'array property cache after update' ); $scalar_changed = $hash_changed = $array_changed = 0; $obj->add_number( five => 4 ); ok( !$scalar_changed, 'scalar unchanged' ); ok( !$array_changed, 'array unchanged' ); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, three => 3, four => 4, five => 4 }, 'hash property cache after wrong five' ); $scalar_changed = $hash_changed = $array_changed = 0; $obj->add_number( five => 5 ); is( $proxy->prop( "scalar" ), "12345", "scalar property cache after five" ); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, three => 3, four => 4, five => 5 }, 'hash property cache after five' ); is_deeply( $proxy->prop( "array" ), [ 1, 2, 3, 4, 5 ], 'array property cache after five' ); $scalar_changed = $hash_changed = $array_changed = 0; $obj->del_number( 3 ); is( $proxy->prop( "scalar" ), "1245", "scalar property cache after delete three" ); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, four => 4, five => 5 }, 'hash property cache after delete three' ); is_deeply( $proxy->prop( "array" ), [ 1, 2, 4, 5 ], 'array property cache after delete three' ); # Just test this directly $obj->set_prop_array( [ 0 .. 9 ] ); $obj->move_prop_array( 3, 2 ); is_deeply( $proxy->prop( "array" ), [ 0, 1, 2, 4, 5, 3, 6, 7, 8, 9 ], 'array property cacahe after move(+2)' ); $obj->move_prop_array( 5, -2 ); is_deeply( $proxy->prop( "array" ), [ 0 .. 9 ], 'array property cacahe after move(-2)' ); { no warnings 'redefine'; local *Tangence::Property::Instance::_forbid_arrayification = sub {}; memory_cycle_ok( $registry, '$registry has no memory cycles' ); memory_cycle_ok( $obj, '$obj has no memory cycles' ); memory_cycle_ok( $proxy, '$proxy has no memory cycles' ); } done_testing; Tangence-0.28/t/32props-cursor.t000444001750001750 477514174566136 15352 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Tangence::Registry; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; my @value; my $on_more = sub { my $idx = shift; @value[$idx .. $idx + $#_] = @_; }; # Fowards from first { my ( $cursor, undef, $last_idx ) = await $proxy->watch_property_with_cursor( "queue", "first", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, ); $#value = $last_idx; is_deeply( \@value, [ undef, undef, undef ], '@value initially' ); $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 1, undef, undef ], '@value after first next_forward' ); $obj->push_prop_queue( 4, 5 ); is_deeply( \@value, [ 1, undef, undef, 4, 5 ], '@value after push' ); $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 1, 2, undef, 4, 5 ], '@value after second next_forward' ); $obj->shift_prop_queue( 1 ); is_deeply( \@value, [ 2, undef, 4, 5 ], '@value after shift' ); $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after third next_forward' ); $proxy->unwatch_property( "queue" ); } # Reset undef @value; $obj->set_prop_queue( [ 1, 2, 3 ] ); # Backwards from last { my ( $cursor, undef, $last_idx ) = await $proxy->watch_property_with_cursor( "queue", "last", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, ); $#value = $last_idx; is_deeply( \@value, [ undef, undef, undef ], '@value initially' ); $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ undef, undef, 3 ], '@value after first next_backward' ); $obj->push_prop_queue( 4, 5 ); is_deeply( \@value, [ undef, undef, 3, 4, 5 ], '@value after push' ); $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ undef, 2, 3, 4, 5 ], '@value after second next_backward' ); $obj->shift_prop_queue( 1 ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after shift' ); $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after third next_backward' ); $proxy->unwatch_property( "queue" ); } done_testing; Tangence-0.28/t/33props-set.t000444001750001750 173014174566136 14615 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Tangence::Registry; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; # scalar { await $proxy->set_property( "scalar", 456 ); is( $obj->get_prop_scalar, 456, 'set_property on scalar' ); } # array { await $proxy->set_property( "array", [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_array, [ 4, 5, 6 ], 'set_property on array' ); } # queue { await $proxy->set_property( "queue", [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_queue, [ 4, 5, 6 ], 'set_property on queue' ); } # hash { await $proxy->set_property( "hash", { four => 4, five => 5 } ); is_deeply( $obj->get_prop_hash, { four => 4, five => 5 }, 'set_property on hash' ); } done_testing; Tangence-0.28/t/40server-security.t000444001750001750 405314174566136 16033 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Future::AsyncAwait 0.47; use Test::More; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", ); # generate a second object that exists but we don't tell the client about my $obj2 = $registry->construct( "t::TestObj", ); my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; # gutwrench into the objectproxy to make a new one with a different ID $proxy->id == $obj->id or die "ARGH failed to have correct object ID in proxy"; my $proxy2 = Tangence::ObjectProxy->new( client => $proxy->client, id => $obj2->id, class => $obj->class, ); # $proxy2 should now not work for anything # methods { my $f = $proxy2->call_method( "method", 0, "" ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects inaccessible by method' ); } # events { my $f = $proxy2->subscribe_event( "event", on_fire => sub {} ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects inaccessible by event' ); } # properties { my $f = $proxy2->get_property( "scalar" ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects inaccessible by property get' ); $f = $proxy2->set_property( "scalar", 123 ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects inaccessible by property set' ); $f = $proxy2->watch_property( "scalar", on_set => sub {} ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects inaccessible by property watch' ); } # as argument to otherwise-allowed object { await $proxy->set_property( "objset", [ $proxy ] ); # is allowed my $f = $proxy->set_property( "objset", [ $proxy2 ] ); like( $f->failure, qr/^Access not allowed to object with id 2/, 'unseen objects not allowed by value' ); } done_testing; Tangence-0.28/t/90close-leak.t000444001750001750 142014174566136 14677 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; BEGIN { plan skip_all => "No Test::MemoryGrowth" unless eval { require Test::MemoryGrowth }; } use Test::MemoryGrowth; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::TestObj; use t::TestServerClient; my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); no_growth { my ( $server, $client ) = make_serverclient( $registry ); my $objproxy = $client->rootobj; $objproxy->watch_property( "scalar", on_set => sub {}, )->get; $server->tangence_closed; $client->tangence_closed; } calls => 1000, 'Connect/watch/disconnect does not grow memory'; done_testing; Tangence-0.28/t/99pod.t000444001750001750 25614174566136 13441 0ustar00leoleo000000000000#!/usr/bin/perl use v5.26; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Tangence-0.28/t/Ball.pm000444001750001750 121714174566136 13536 0ustar00leoleo000000000000package t::Ball; use v5.26; use warnings; use experimental 'signatures'; use base qw( Tangence::Object t::Colourable ); use Tangence::Constants; sub new ( $class, %args ) { my $self = $class->SUPER::new( %args ); $self->set_prop_colour( $args{colour} ) if defined $args{colour}; $self->set_prop_size( $args{size} ) if defined $args{size}; return $self; } sub describe { my $self = shift; return (ref $self) . qq([colour=") . $self->get_prop_colour . q("]); } our $last_bounce_ctx; sub method_bounce ( $self, $ctx, $howhigh ) { $last_bounce_ctx = $ctx; $self->fire_event( "bounced", $howhigh ); return "bouncing"; } 1; Tangence-0.28/t/Ball.tan000444001750001750 24014174566136 13657 0ustar00leoleo000000000000include "Colourable.tan" class t.Ball { isa t.Colourable; method bounce(str howhigh) -> str; event bounced(str howhigh); smashed prop size = int; } Tangence-0.28/t/Colourable.pm000444001750001750 23014174566136 14725 0ustar00leoleo000000000000package t::Colourable; use v5.26; use Tangence::Constants; our %PROPS = ( colour => { dim => DIM_SCALAR, type => 'str', }, ); 1; Tangence-0.28/t/Colourable.tan000444001750001750 5414174566136 15057 0ustar00leoleo000000000000class t.Colourable { prop colour = str; } Tangence-0.28/t/Conversation.pm000444001750001750 1761414174566136 15366 0ustar00leoleo000000000000package t::Conversation; use v5.26; use warnings; use Exporter 'import'; our @EXPORT = qw( %S2C %C2S $MSG_OK ); our %S2C; our %C2S; our $MSG_OK = "\x80" . "\0\0\0\0"; # This module contains the string values used in various testing scripts that # act as an example conversation between server and client. The strings are # kept here in order to avoid mass duplication between the other testing # modules, and to try to shield unwary visitors from the mass horror that is # the following collection of large hex-encoded strings. # If you are sitting comfortably, our story begings with the client... # MSG_INIT $C2S{INIT} = "\x7f" . "\0\0\0\6" . "\x02" . "\0" . "\x02" . "\4" . "\x02" . "\3"; # MSG_INITED $S2C{INITED} = "\xff" . "\0\0\0\4" . "\x02" . "\0" . "\x02" . "\4"; # MSG_GETROOT $C2S{GETROOT} = "\x40" . "\0\0\0\x0b" . "\x2a" . "testscript"; $S2C{GETROOT} = "\x82" . "\0\0\0\xf8" . "\xe2" . "\x29t.TestObj" . "\x02\1" . "\xa4" . "\x02\1" . "\x62" . "\x26method" . "\xa2" . "\x02\2" . "\x42" . "\x23int" . "\x23str" . "\x23str" . "\x28noreturn" . "\xa2" . "\x02\2" . "\x40" . "\x20" . "\x61" . "\x25event" . "\xa1" . "\x02\3" . "\x42" . "\x23int" . "\x23str" . "\x68" . "\x25array" . "\xa3" . "\x02\4" . "\x02\4" . "\x23int" . "\x00" . "\x24hash" . "\xa3" . "\x02\4" . "\x02\2" . "\x23int" . "\x00" . "\x25items" . "\xa3" . "\x02\4" . "\x02\1" . "\x29list(obj)" . "\x00" . "\x26objset" . "\xa3" . "\x02\4" . "\x02\5" . "\x23obj" . "\x00" . "\x25queue" . "\xa3" . "\x02\4" . "\x02\3" . "\x23int" . "\x00" . "\x27s_array" . "\xa3" . "\x02\4" . "\x02\4" . "\x23int" . "\x01" . "\x28s_scalar" . "\xa3" . "\x02\4" . "\x02\1" . "\x23int" . "\x01" . "\x26scalar" . "\xa3" . "\x02\4" . "\x02\1" . "\x23int" . "\x00" . "\x40" . "\x42" . "\x27s_array" . "\x28s_scalar" . "\xe1" . "\x02\1" . "\x02\1" . "\x42" . "\x40" . "\x04\x01\xc8" . "\x84" . "\0\0\0\1"; # MSG_GETREGISTRY $C2S{GETREGISTRY} = "\x41" . "\0\0\0\0"; $S2C{GETREGISTRY} = "\x82" . "\0\0\0\x84" . "\xe2" . "\x31Tangence.Registry" . "\x02\2" . "\xa4" . "\x02\1" . "\x61" . "\x29get_by_id" . "\xa2" . "\x02\2" . "\x41" . "\x23" . "int" . "\x23" . "obj" . "\x62" . "\x32object_constructed" . "\xa1" . "\x02\3" . "\x41" . "\x23" . "int" . "\x30object_destroyed" . "\xa1" . "\x02\3" . "\x41" . "\x23" . "int" . "\x61" . "\x27objects" . "\xa3" . "\x02\4" . "\x02\2" . "\x23" . "str" . "\x00" . "\x40" . "\x40" . "\xe1" . "\x02\0" . "\x02\2" . "\x40" . "\x84" . "\0\0\0\0"; # MSG_CALL $C2S{CALL} = "\1" . "\0\0\0\x11" . "\x02\x01" . "\x26method" . "\x02\x0a" . "\x25hello"; # MSG_RESULT $S2C{CALL} = "\x82" . "\0\0\0\x09" . "\x2810/hello"; $C2S{CALL_NORETURN} = "\1" . "\0\0\0\x0b" . "\x02\x01" . "\x28noreturn"; $S2C{CALL_NORETURN} = "\x82" . "\0\0\0\0"; # MSG_SUBSCRIBE $C2S{SUBSCRIBE} = "\2" . "\0\0\0\x08" . "\x02\1" . "\x25event"; $S2C{SUBSCRIBED} = "\x83" . "\0\0\0\0"; $C2S{UNSUBSCRIBE} = "\3" . "\0\0\0\x08" . "\x02\1" . "\x25event"; # MSG_EVENT $S2C{EVENT} = "\4" . "\0\0\0\x0e" . "\x02\1" . "\x25event" . "\x02\x14" . "\x23bye"; # MSG_GETPROP $C2S{GETPROP} = "\5" . "\0\0\0\x09" . "\x02\1" . "\x26scalar"; $S2C{GETPROP_123} = "\x82" . "\0\0\0\2" . "\x02\x7b"; $S2C{GETPROP_147} = "\x82" . "\0\0\0\2" . "\x02\x93"; # MSG_GETPROPELEM $C2S{GETPROPELEM_HASH} = "\x0b" . "\0\0\0\x0b" . "\x02\1" . "\x24hash" . "\x23two"; $S2C{GETPROPELEM_HASH} = "\x82" . "\0\0\0\2" . "\x02\2"; $C2S{GETPROPELEM_ARRAY} = "\x0b" . "\0\0\0\x0a" . "\x02\1" . "\x25array" . "\x02\1"; $S2C{GETPROPELEM_ARRAY} = "\x82" . "\0\0\0\2" . "\x02\2"; # MSG_SETPROP $C2S{SETPROP} = "\6" . "\0\0\0\x0b" . "\x02\1" . "\x26scalar" . "\x02\x87"; # MSG_GETPROPELEM $C2S{GETPROPELEM_BLUE} = "\x0b" . "\0\0\0\x0f" . "\x02" . "\x01" . "\x27" . "colours" . "\x24" . "blue"; $S2C{GETPROPELEM_BLUE} = "\x82" . "\0\0\0\2" . "\x02" . "\x01"; # MSG_WATCH $C2S{WATCH} = "\7" . "\0\0\0\x0a" . "\x02\1" . "\x26scalar" . "\x00"; $S2C{WATCHING} = "\x84" . "\0\0\0\0"; $C2S{UNWATCH} = "\x08" . "\0\0\0\x09" . "\x02\1" . "\x26scalar"; # MSG_WATCH_ITER $C2S{WATCH_ITER} = "\x0c" . "\0\0\0\x0a" . "\x02\1" . "\x25queue" . "\x02\1"; $S2C{WATCHING_ITER} = "\x85" . "\0\0\0\6" . "\x02\1" . "\x02\0" . "\x02\2"; $C2S{ITER_NEXT_1} = "\x0d" . "\0\0\0\6" . "\x02\1" . "\x02\1" . "\x02\1"; $S2C{ITER_NEXT_1} = "\x86" . "\0\0\0\4" . "\x02\0" . "\x02\1"; $C2S{ITER_NEXT_5} = "\x0d" . "\0\0\0\6" . "\x02\1" . "\x02\1" . "\x02\5"; $S2C{ITER_NEXT_5} = "\x86" . "\0\0\0\6" . "\x02\1" . "\x02\2" . "\x02\3"; $C2S{ITER_NEXT_BACK} = "\x0d" . "\0\0\0\6" . "\x02\1" . "\x02\2" . "\x02\1"; $S2C{ITER_NEXT_BACK} = "\x86" . "\0\0\0\4" . "\x02\2" . "\x02\3"; $C2S{ITER_DESTROY} = "\x0e" . "\0\0\0\2" . "\x02\1"; # MSG_UPDATE $S2C{UPDATE_SCALAR_147} = "\x09" . "\0\0\0\x0d" . "\x02\1" . "\x26scalar" . "\x02\1" . "\x02\x93"; $S2C{UPDATE_SCALAR_159} = "\x09" . "\0\0\0\x0d" . "\x02\1" . "\x26scalar" . "\x02\1" . "\x02\x9f"; $S2C{UPDATE_S_SCALAR_468} = "\x09" . "\0\0\0\x10" . "\x02\1" . "\x28s_scalar" . "\x02\1" . "\x04\x01\xd4"; # MSG_DESTROY $S2C{DESTROY} = "\x0a" . "\0\0\0\2" . "\x02\1"; Tangence-0.28/t/TestObj.pm000444001750001750 326414174566136 14242 0ustar00leoleo000000000000package t::TestObj; use v5.26; use warnings; use experimental 'signatures'; use base qw( Tangence::Object ); use Tangence::Constants; sub new ( $class, %args ) { my $self = $class->SUPER::new( %args ); for (qw( scalar array queue hash s_scalar )) { $self->${\"set_prop_$_"}( $args{$_} ) if defined $args{$_}; } return $self; } sub describe { my $self = shift; return (ref $self) . qq([scalar=) . $self->get_prop_scalar . q(]); } sub method_method ( $self, $ctx, $i, $s ) { return "$i/$s"; } sub method_noreturn { my $self = shift; return; } sub init_prop_scalar { 123 } sub init_prop_hash { { one => 1, two => 2, three => 3 } } sub init_prop_queue { [ 1, 2, 3 ] } sub init_prop_array { [ 1, 2, 3 ] } sub add_number ( $self, $name, $num ) { if( index( my $scalar = $self->get_prop_scalar, $num ) == -1 ) { $scalar .= $num; $self->set_prop_scalar( $scalar ); } $self->add_prop_hash( $name, $num ); if( !grep { $_ == $num } @{ $self->get_prop_array } ) { $self->push_prop_array( $num ); } } sub del_number ( $self, $num ) { my $hash = $self->get_prop_hash; my $name; $hash->{$_} == $num and ( $name = $_, last ) for keys %$hash; defined $name or die "No name for $num"; if( index( ( my $scalar = $self->get_prop_scalar ), $num ) != -1 ) { $scalar =~ s/\Q$num//; $self->set_prop_scalar( $scalar ); } $self->del_prop_hash( $name ); my $array = $self->get_prop_array; if( grep { $_ == $num } @$array ) { my $index; $array->[$_] == $num and ( $index = $_, last ) for 0 .. $#$array; $index == 0 ? $self->shift_prop_array() : $self->splice_prop_array( $index, 1, () ); } } 1; Tangence-0.28/t/TestObj.tan000444001750001750 73114174566136 14364 0ustar00leoleo000000000000class t.TestObj { method method(int i, str s) -> str; method noreturn(); event event(int i, str s); prop scalar = int; prop hash = hash of int; prop queue = queue of int; prop array = array of int; prop objset = objset of obj; prop items = list(obj); smashed prop s_scalar = int; smashed prop s_array = array of int; } struct t.TestStruct { field b = bool; field i = int; field f = float; field s = str; field o = obj; } Tangence-0.28/t/TestServerClient.pm000444001750001750 214714174566136 16134 0ustar00leoleo000000000000package t::TestServerClient; use v5.26; use warnings; use experimental 'signatures'; use Exporter 'import'; our @EXPORT = qw( make_serverclient ); use Scalar::Util qw( weaken ); sub make_serverclient ( $registry ) { my $server = TestServer->new(); my $client = TestClient->new(); $server->registry( $registry ); weaken( $server->{client} = $client ); weaken( $client->{server} = $server ); $client->tangence_connected(); return ( $server, $client ); } package TestServer; use base qw( Tangence::Server ); sub new { return bless {}, shift; } sub tangence_write ( $self, $message ) { $self->{client}->tangence_readfrom( $message ); length($message) == 0 or die "Client failed to read all Server wrote"; } package TestClient; use base qw( Tangence::Client ); sub new { my $self = bless {}, shift; $self->identity( "testscript" ); $self->on_error( sub { die "Test failed early - $_[0]" } ); return $self; } sub tangence_write ( $self, $message ) { $self->{server}->tangence_readfrom( $message ); length($message) == 0 or die "Server failed to read all Client wrote"; }