Net-Async-Tangence-0.15000755001750001750 013607230017 13502 5ustar00leoleo000000000000Net-Async-Tangence-0.15/Build.PL000444001750001750 160413607230017 15134 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Net::Async::Tangence', requires => { 'Encode' => 0, 'Exporter' => '5.57', 'Future' => 0, 'IO::Async::Listener' => '0.36', 'IO::Async::Loop' => '0.16', 'IO::Async::Stream' => 0, 'IO::Async::Test' => 0, 'Tangence::Client' => '0.25', # ->get_registry 'Tangence::Server' => '0.19', 'URI' => 0, }, build_requires => { 'Test::Fatal' => '0.006', 'Test::HexString' => 0, 'Test::Identity' => 0, 'Test::Memory::Cycle' => 0, 'Test::More' => '0.88', # done_testing 'Test::Refcount' => 0, }, auto_configure_requires => 0, # Don't add M::B to configure_requires license => 'perl', create_makefile_pl => 'traditional', create_license => 1, create_readme => 1, ); $build->create_build_script; Net-Async-Tangence-0.15/Changes000444001750001750 364413607230017 15141 0ustar00leoleo000000000000Revision history for Net-Async-Tangence 0.15 2020-01-14 [CHANGES] * More unit testing of connection methods * Updated for Tangence 0.25 * Added server override hooks for per-connection registry permission and rootobj 0.14 2017/01/08 00:38:11 [BUGFIXES] * Enable arrayification of Struct::Dumb instances while Devel::Cycle is looking at them (RT119750) * Add 'use lib ".";' to keep perl 5.24+ happy 0.13 2015/10/28 21:09:06 [BREAKING CHANGES] * Client API returns Futures * Use Tangence 0.21's Future-returning ObjectProxy API 0.12 2014/07/18 00:57:31 [CHANGES] * Don't subclass from now-deprecated IO::Async::Protocol::Stream [BUGFIXES] * Prevent memory leak on disconnect by ensuring that C3 MRO is in effect for "diamond-of-death" structure of ServerProtocol 0.11 CHANGES: * ->socketpair is now in IO::Async::OS not $loop 0.10 CHANGES: * Rewrite unit tests for Tangence 0.17 * Version-guard binary protocol-dependent unit tests so they degrade gracefully in future 0.09 CHANGES: * Renamed ssh:// URL scheme to sshexec:// * Added sshunix:// URL scheme that allows directly connecting to a UNIX socket on the server 0.08 CHANGES: * Renamed Net::Async::Tangence::Client->connect to ->connect_url so it doesn't collide with IO::Async::Protocol's method * More unit testing 0.07 CHANGES: * Updated for Tangence 0.07; no longer declares isa Tangence::Object in over-the-wire introspection 0.06 CHANGES: * Updated for Tangence 0.06; provide tanfiles instead of in-source package vars for metadata * Use Test::Fatal instead of Test::Exception 0.05 CHANGES: * Split modules out from base Tangence distribution Net-Async-Tangence-0.15/LICENSE000444001750001750 4376213607230017 14700 0ustar00leoleo000000000000This software is copyright (c) 2020 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) 2020 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) 2020 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 Net-Async-Tangence-0.15/MANIFEST000444001750001750 131213607230017 14765 0ustar00leoleo000000000000bin/tangence-introspect bin/tangence-subscribeall Build.PL Changes lib/Net/Async/Tangence.pm lib/Net/Async/Tangence/Client.pm lib/Net/Async/Tangence/Client/via/sshexec.pm lib/Net/Async/Tangence/Client/via/sshunix.pm lib/Net/Async/Tangence/Protocol.pm lib/Net/Async/Tangence/Server.pm lib/Net/Async/Tangence/ServerProtocol.pm LICENSE Makefile.PL MANIFEST This list of files META.json META.yml README t/00use.t t/01protocol.t t/02server.t t/03client.t t/04xlink.t t/05close.t t/20connect-exec.t t/20connect-sshexec.t t/20connect-sshunix.t t/20connect-tcp.t t/20connect-unix.t t/90close-leak.t t/99pod.t t/Ball.pm t/Ball.tan t/Colourable.pm t/Colourable.tan t/Conversation.pm t/server.pl t/TestObj.pm t/TestObj.tan Net-Async-Tangence-0.15/META.json000444001750001750 441213607230017 15261 0ustar00leoleo000000000000{ "abstract" : "use C with C", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-Async-Tangence", "prereqs" : { "build" : { "requires" : { "Test::Fatal" : "0.006", "Test::HexString" : "0", "Test::Identity" : "0", "Test::Memory::Cycle" : "0", "Test::More" : "0.88", "Test::Refcount" : "0" } }, "runtime" : { "requires" : { "Encode" : "0", "Exporter" : "5.57", "Future" : "0", "IO::Async::Listener" : "0.36", "IO::Async::Loop" : "0.16", "IO::Async::Stream" : "0", "IO::Async::Test" : "0", "Tangence::Client" : "0.25", "Tangence::Server" : "0.19", "URI" : "0" } } }, "provides" : { "Net::Async::Tangence" : { "file" : "lib/Net/Async/Tangence.pm", "version" : "0.15" }, "Net::Async::Tangence::Client" : { "file" : "lib/Net/Async/Tangence/Client.pm", "version" : "0.15" }, "Net::Async::Tangence::Client::via::sshexec" : { "file" : "lib/Net/Async/Tangence/Client/via/sshexec.pm", "version" : "0.15" }, "Net::Async::Tangence::Client::via::sshunix" : { "file" : "lib/Net/Async/Tangence/Client/via/sshunix.pm", "version" : "0.15" }, "Net::Async::Tangence::Protocol" : { "file" : "lib/Net/Async/Tangence/Protocol.pm", "version" : "0.15" }, "Net::Async::Tangence::Server" : { "file" : "lib/Net/Async/Tangence/Server.pm", "version" : "0.15" }, "Net::Async::Tangence::ServerProtocol" : { "file" : "lib/Net/Async/Tangence/ServerProtocol.pm", "version" : "0.15" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.15", "x_serialization_backend" : "JSON::PP version 4.04" } Net-Async-Tangence-0.15/META.yml000444001750001750 304313607230017 15110 0ustar00leoleo000000000000--- abstract: 'use C with C' author: - 'Paul Evans ' build_requires: Test::Fatal: '0.006' Test::HexString: '0' Test::Identity: '0' Test::Memory::Cycle: '0' Test::More: '0.88' Test::Refcount: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.4224, 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: Net-Async-Tangence provides: Net::Async::Tangence: file: lib/Net/Async/Tangence.pm version: '0.15' Net::Async::Tangence::Client: file: lib/Net/Async/Tangence/Client.pm version: '0.15' Net::Async::Tangence::Client::via::sshexec: file: lib/Net/Async/Tangence/Client/via/sshexec.pm version: '0.15' Net::Async::Tangence::Client::via::sshunix: file: lib/Net/Async/Tangence/Client/via/sshunix.pm version: '0.15' Net::Async::Tangence::Protocol: file: lib/Net/Async/Tangence/Protocol.pm version: '0.15' Net::Async::Tangence::Server: file: lib/Net/Async/Tangence/Server.pm version: '0.15' Net::Async::Tangence::ServerProtocol: file: lib/Net/Async/Tangence/ServerProtocol.pm version: '0.15' requires: Encode: '0' Exporter: '5.57' Future: '0' IO::Async::Listener: '0.36' IO::Async::Loop: '0.16' IO::Async::Stream: '0' IO::Async::Test: '0' Tangence::Client: '0.25' Tangence::Server: '0.19' URI: '0' resources: license: http://dev.perl.org/licenses/ version: '0.15' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-Async-Tangence-0.15/Makefile.PL000444001750001750 212713607230017 15613 0ustar00leoleo000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4224 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Net::Async::Tangence', 'VERSION_FROM' => 'lib/Net/Async/Tangence.pm', 'PREREQ_PM' => { 'Encode' => 0, 'Exporter' => '5.57', 'Future' => 0, 'IO::Async::Listener' => '0.36', 'IO::Async::Loop' => '0.16', 'IO::Async::Stream' => 0, 'IO::Async::Test' => 0, 'Tangence::Client' => '0.25', 'Tangence::Server' => '0.19', 'Test::Fatal' => '0.006', 'Test::HexString' => 0, 'Test::Identity' => 0, 'Test::Memory::Cycle' => 0, 'Test::More' => '0.88', 'Test::Refcount' => 0, 'URI' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [ 'bin/tangence-introspect', 'bin/tangence-subscribeall' ], 'PL_FILES' => {} ) ; Net-Async-Tangence-0.15/README000444001750001750 117613607230017 14524 0ustar00leoleo000000000000NAME Net::Async::Tangence - use Tangence with IO::Async DESCRIPTION This distribution provides concrete implementations of the Tangence base classes, allowing either servers or clients to be written based on IO::Async. To implement a server, see Net::Async::Tangence::Server. To implement a client, see Net::Async::Tangence::Client. This module itself does not provide any code, and exists only to provide the module $VERSION and top-level documentation. SEE ALSO * Tangence - attribute-oriented server/client object remoting framework AUTHOR Paul Evans Net-Async-Tangence-0.15/bin000755001750001750 013607230017 14252 5ustar00leoleo000000000000Net-Async-Tangence-0.15/bin/tangence-introspect000555001750001750 441613607230017 20316 0ustar00leoleo000000000000#!/usr/bin/perl -w use strict; use warnings; use Tangence::Client 0.25; # ->get_registry use Net::Async::Tangence::Client; use IO::Async::Loop 0.16; use Data::Dump; # We want to mangle the way Data::Dump prints our object proxies # While we're at it, lets build a generic delegated printing system { my $_dump = \&Data::Dump::_dump; my %dump_delegations; no warnings 'redefine'; *Data::Dump::_dump = sub { if( exists $dump_delegations{ref $_[0]} ) { return $dump_delegations{ref $_[0]}->( @_ ); } else { return $_dump->( @_ ); } }; sub register_dump_delegation { my ( $class, $cb ) = @_; $dump_delegations{$class} = $cb; } } register_dump_delegation( "Tangence::ObjectProxy" => sub { my ( $obj ) = @_; return "OBJPROXY( id=$obj->{id}, props=" . Data::Dump::dump($obj->{props}) . " )"; } ); my $loop = IO::Async::Loop->new(); my $URL = shift @ARGV or die "Need URL as argv[1]\n"; my $conn = Net::Async::Tangence::Client->new( on_closed => sub { print STDERR "Connection closed\n"; exit(0); }, on_error => sub { my ( $message ) = @_; print STDERR "Error: $message\n"; $loop->loop_stop; }, ); $loop->add( $conn ); $conn->connect_url( $URL )->get; my $registry = $conn->get_registry->get;; if( !@ARGV ) { my $objshash = $registry->get_property( "objects" )->get; foreach my $id ( sort { $a <=> $b } keys %$objshash ) { my $desc = $objshash->{$id}; printf "%-6d: %s\n", $id, $desc; } } elsif( $ARGV[0] eq "-i" ) { shift @ARGV; # eat -i my $objid = shift @ARGV; my $obj = $registry->call_method( "get_by_id", $objid )->get; print "Object is a " . $obj->classname . "\n"; my $class = $obj->class; print "Class supports:\n"; print " method $_\n" for keys %{ $class->methods }; print " event $_\n" for keys %{ $class->events }; print " property $_\n" for keys %{ $class->properties }; } elsif( $ARGV[0] eq "-p" ) { shift @ARGV; # eat -p my $objid = shift @ARGV; my $property = shift @ARGV; my $obj = $registry->call_method( "get_by_id", $objid )->get; my $value = $obj->get_property( $property )->get; print Data::Dump::dump( $value ) . "\n"; } else { die "Unrecognised operation $ARGV[0]\n"; } Net-Async-Tangence-0.15/bin/tangence-subscribeall000555001750001750 1451513607230017 20617 0ustar00leoleo000000000000#!/usr/bin/perl -w use strict; use warnings; use Tangence::Client 0.25; # ->get_registry use Net::Async::Tangence::Client; use Tangence::Constants; use IO::Async::Loop 0.16; use Data::Dump; # We want to mangle the way Data::Dump prints our object proxies # While we're at it, lets build a generic delegated printing system { my $_dump = \&Data::Dump::_dump; my %dump_delegations; no warnings 'redefine'; *Data::Dump::_dump = sub { if( exists $dump_delegations{ref $_[0]} ) { return $dump_delegations{ref $_[0]}->( @_ ); } else { return $_dump->( @_ ); } }; sub register_dump_delegation { my ( $class, $cb ) = @_; $dump_delegations{$class} = $cb; } } register_dump_delegation( "Tangence::ObjectProxy" => sub { my ( $obj ) = @_; return "OBJPROXY( id=$obj->{id} )"; } ); my $loop = IO::Async::Loop->new(); my $URL = shift @ARGV or die "Need URL as argv[1]\n"; my $conn = Net::Async::Tangence::Client->new( on_closed => sub { print STDERR "Connection closed\n"; exit(0); }, on_error => sub { my ( $message ) = @_; print STDERR "Error: $message\n"; }, ); $loop->add( $conn ); $conn->connect_url( $URL )->get; my $registry = $conn->get_registry->get; $registry->watch_property_with_initial( "objects", on_set => sub { my ( $objects ) = @_; new_object( $_ ) foreach keys %$objects; }, on_add => sub { my ( $id, $obj ) = @_; new_object( $id ); }, on_del => sub { my ( $id ) = @_; print STDERR "deleted object $id\n"; }, )->get; $loop->loop_forever; sub new_object { my ( $objid ) = @_; print "Subscribing to events and properties on new object $objid\n"; my $obj = $registry->call_method( "get_by_id", $objid )->get; unless( $obj ) { warn "Registry did not give us an object at ID=$objid\n"; return; } my $class = $obj->class; my @f; foreach my $event ( keys %{ $class->events } ) { print "Subscribing to object $objid event $event\n"; push @f, object_event( $obj, $event ); } foreach my $prop ( keys %{ $class->properties } ) { # We're already watching 'objects' on the registry, so ignore that next if $objid == 0 and $prop eq "objects"; print "Watching object $objid property $prop\n"; # Need to handle based on the property dimension my $dim = $class->property( $prop )->dimension; my $install = $dim == DIM_SCALAR ? \&object_prop_scalar : $dim == DIM_HASH ? \&object_prop_hash : $dim == DIM_QUEUE ? \&object_prop_queue : $dim == DIM_ARRAY ? \&object_prop_array : $dim == DIM_OBJSET ? \&object_prop_objset : undef; push @f, $install->( $obj, $prop ) if defined $install; } Future->needs_all( @f )->get; } sub object_event { my ( $obj, $event ) = @_; my $id = $obj->id; $obj->subscribe_event( $event, on_fire => sub { my ( @args ) = @_; print "EVENT $id -> $event\n"; print " " . Data::Dump::dump(@args) . "\n"; }, ); } sub object_prop_scalar { my ( $obj, $prop ) = @_; my $id = $obj->id; $obj->watch_property_with_initial( $prop, on_set => sub { my ( $scalar ) = @_; print "PROP SET $id [$prop]\n"; print " " . Data::Dump::dump($scalar) . "\n"; }, ); } sub object_prop_hash { my ( $obj, $prop ) = @_; my $id = $obj->id; $obj->watch_property_with_initial( $prop, on_set => sub { my ( $hash ) = @_; print "PROP SET $id [$prop]\n"; print " {$_} = " . Data::Dump::dump($hash->{$_}) . "\n" for sort keys %$hash; }, on_add => sub { my ( $key, $value ) = @_; print "PROP ADD $id [$prop]\n"; print " {$key} = " . Data::Dump::dump($value) . "\n"; }, on_del => sub { my ( $key ) = @_; print "PROP DEL $id [$prop]\n"; print " {$key}\n"; }, ); } sub object_prop_array { my ( $obj, $prop ) = @_; my $id = $obj->id; $obj->watch_property( $prop, on_set => sub { my ( $array ) = @_; print "PROP SET $id [$prop]\n"; print " [$_] = " . Data::Dump::dump($array->[$_]) . "\n" for 0 .. $#$array; }, on_push => sub { my ( @newvals ) = @_; print "PROP PUSH $id [$prop]\n"; print " : " . Data::Dump::dump($newvals[$_]) . "\n" for 0 .. $#newvals; }, on_shift => sub { my ( $count ) = @_; print "PROP SHIFT $id [$prop]\n"; print " shift x $count\n"; }, on_splice => sub { my ( $index, $count, @newvals ) = @_; print "PROP SPLICE $id [$prop]\n"; print " splice[$index .. $index+$count] = \n"; print " : " . Data::Dump::dump($newvals[$_]) . "\n" for 0 .. $#newvals; }, on_move => sub { my ( $index, $delta ) = @_; print "PROP MOVE $id [$prop]\n"; print " [$index] by ".($delta>0?"+$delta":"$delta")."\n"; }, ); } sub object_prop_queue { my ( $obj, $prop ) = @_; my $id = $obj->id; $obj->watch_property_with_initial( $prop, on_set => sub { my ( $queue ) = @_; print "PROP SET $id [$prop]\n"; print " [$_] = " . Data::Dump::dump($queue->[$_]) . "\n" for 0 .. $#$queue; }, on_push => sub { my ( @newvals ) = @_; print "PROP PUSH $id [$prop]\n"; print " : " . Data::Dump::dump($newvals[$_]) . "\n" for 0 .. $#newvals; }, on_shift => sub { my ( $count ) = @_; print "PROP SHIFT $id [$prop]\n"; print " shift x $count\n"; }, ); } sub object_prop_objset { my ( $obj, $prop ) = @_; my $id = $obj->id; $obj->watch_property_with_initial( $prop, on_set => sub { my ( $objs ) = @_; print "PROP SET $id [$prop]\n"; print " " . $_->id . " = " . Data::Dump::dump($_) . "\n" for values %$objs; }, on_add => sub { my ( $newobj ) = @_; print "PROP ADD $id [$prop]\n"; print " " . $newobj->id . " = " . Data::Dump::dump($newobj) . "\n"; }, on_del => sub { my ( $delid ) = @_; print "PROP DEL $id [$prop]\n"; print " $delid\n"; }, ); } Net-Async-Tangence-0.15/lib000755001750001750 013607230017 14250 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net000755001750001750 013607230017 14776 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net/Async000755001750001750 013607230017 16053 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net/Async/Tangence.pm000444001750001750 170113607230017 20271 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 -- leonerd@leonerd.org.uk package Net::Async::Tangence; use strict; use warnings; our $VERSION = '0.15'; =head1 NAME C - use C with C =head1 DESCRIPTION This distribution provides concrete implementations of the L base classes, allowing either servers or clients to be written based on L. To implement a server, see L. To implement a client, see L. This module itself does not provide any code, and exists only to provide the module C<$VERSION> and top-level documentation. =cut =head1 SEE ALSO =over 8 =item * L - attribute-oriented server/client object remoting framework =back =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence000755001750001750 013607230017 17577 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Client.pm000444001750001750 1660613607230017 21541 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-2017 -- leonerd@leonerd.org.uk package Net::Async::Tangence::Client; use strict; use warnings; use base qw( Net::Async::Tangence::Protocol Tangence::Client ); our $VERSION = '0.15'; use Carp; use Future; use Scalar::Util qw( blessed ); use URI; =head1 NAME C - connect to a C server using C =head1 DESCRIPTION This subclass of L connects to a L server, allowing the client program to access exposed objects in the server. It is a concrete implementation of the C mixin. The following documentation concerns this specific implementation of the client; for more general information on the C-specific parts of this class, see instead the documentation for L. =cut sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( %args ); # It's possible a handle was passed in the constructor. $self->tangence_connected( %args ) if defined $self->read_handle; return $self; } =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item identity => STRING The identity string to send to the server. =item on_error => STRING or CODE Default error-handling policy for method calls. If set to either of the strings C or C then a CODE ref will be created that invokes the given function from C; otherwise must be a CODE ref. =back =cut sub _init { my $self = shift; my ( $params ) = @_; $self->identity( delete $params->{identity} ); $self->SUPER::_init( $params ); $params->{on_error} ||= "croak"; } sub configure { my $self = shift; my %params = @_; if( my $on_error = delete $params{on_error} ) { if( ref $on_error eq "CODE" ) { # OK } elsif( $on_error eq "croak" ) { $on_error = sub { croak "Received MSG_ERROR: $_[0]" }; } elsif( $on_error eq "carp" ) { $on_error = sub { carp "Received MSG_ERROR: $_[0]" }; } else { croak "Expected 'on_error' to be CODE reference or strings 'croak' or 'carp'"; } $self->on_error( $on_error ); } $self->SUPER::configure( %params ); } =head1 METHODS The following methods documented with a trailing call to C<< ->get >> return L instances. =cut sub new_future { my $self = shift; return $self->loop->new_future; } =head2 connect_url $rootobj = $client->connect_url( $url, %args )->get Connects to a C server at the given URL. The returned L will yield the root object proxy once it has been obtained. Takes the following named arguments: =over 8 =item on_registry => CODE =item on_root => CODE Invoked once the registry and root object proxies have been obtained from the server. See the documentation the L C method. =back The following URL schemes are recognised: =over 4 =cut sub connect_url { my $self = shift; my ( $url, %args ) = @_; my $uri = ( blessed $url && $url->isa( "URI" ) ) ? $url : URI->new( $url ); my $scheme = $uri->scheme; if( $scheme =~ m/\+/ ) { $scheme =~ s/^circle\+// or croak "Found a + within URL scheme that is not 'circle+'"; } # Legacy name $scheme = "sshexec" if $scheme eq "ssh"; my $authority = $uri->authority; my $path = $uri->path; # Path will start with a leading /; we need to trim that $path =~ s{^/}{}; my $query = $uri->query; defined $query or $query = ""; my $f; if( $scheme eq "exec" ) { # $query will contain args to exec - split them on + $f = $self->connect_exec( [ $path, split m/\+/, $query ] ); } elsif( $scheme eq "tcp" ) { $f = $self->connect_tcp( $authority ); } elsif( $scheme eq "unix" ) { $f = $self->connect_unix( $path ); } else { my $connectorpkg = "Net::Async::Tangence::Client::via::$scheme"; ( my $connectorfile = "$connectorpkg.pm" ) =~ s{::}{/}g; if( eval { require $connectorfile } and my $code = $connectorpkg->can( 'connect' ) ) { $f = $code->( $self, $uri ); } else { croak "Unrecognised URL scheme name '$scheme'"; } } return $f->then( sub { my $on_root = $args{on_root}; my $root_f = $self->new_future; $self->tangence_connected( %args, on_root => sub { my ( $root ) = @_; $on_root->( $root ) if $on_root; $root_f->done( $root ); }, ); $root_f; }); } =item * exec Directly executes the server as a child process. This is largely provided for testing purposes, as the server will only run for this one client; it will exit when the client disconnects. exec:///path/to/command?with+arguments The URL's path should point to the required command, and the query string will be split on C<+> signs and used as the arguments. The authority section of the URL will be ignored, so may be left empty. =cut sub connect_exec { my $self = shift; my ( $command ) = @_; my $loop = $self->get_loop; pipe( my $myread, my $childwrite ) or croak "Cannot pipe - $!"; pipe( my $childread, my $mywrite ) or croak "Cannoe pipe - $!"; $loop->spawn_child( command => $command, setup => [ stdin => $childread, stdout => $childwrite, ], on_exit => sub { my ( undef, $exitcode, $dollarbang ) = @_; print STDERR "Child exited unexpectedly (status=$exitcode, \$!=$dollarbang)\n"; }, ); $self->configure( read_handle => $myread, write_handle => $mywrite, ); Future->done; } =item * sshexec A convenient wrapper around the C scheme, to connect to a server running remotely via F. sshexec://host/path/to/command?with+arguments The URL's authority section will give the SSH server (and optionally username), and the path and query sections will be used as for C. (This scheme is also available as C, though this name is now deprecated) =cut =item * tcp Connects to a server via a TCP socket. tcp://host:port/ The URL's authority section will be used to give the server's hostname and port number. The other sections of the URL will be ignored. =cut sub connect_tcp { my $self = shift; my ( $authority ) = @_; my ( $host, $port ) = $authority =~ m/^(.*):(.*)$/; $self->connect( host => $host, service => $port, ); } =item * unix Connects to a server via a UNIX local socket. unix:///path/to/socket The URL's path section will give the path to the local socket. The other sections of the URL will be ignored. =cut sub connect_unix { my $self = shift; my ( $path ) = @_; $self->connect( addr => { family => 'unix', socktype => 'stream', path => $path, }, ); } =item * sshunix Connects to a server running remotely via a UNIX socket over F. sshunix://host/path/to/socket (This is implemented by running F remotely and sending it a tiny self-contained program that connects STDIN/STDOUT to the given UNIX socket path. It requires that the server has F at least version 5.6 available in the path simply as C) =cut =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Protocol.pm000444001750001750 325213607230017 22075 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-2011 -- leonerd@leonerd.org.uk package Net::Async::Tangence::Protocol; use strict; use warnings; our $VERSION = '0.15'; use base qw( IO::Async::Stream Tangence::Stream ); use Carp; =head1 NAME C - concrete implementation of C for C =head1 DESCRIPTION This subclass of L provides a concrete implementation of the L mixin. It is not intended to be directly used by server implementations. Instead, it is subclassed as L and L. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( $params ); $params->{on_closed} ||= undef; } sub configure { my $self = shift; my %params = @_; if( exists $params{on_closed} ) { my $on_closed = delete $params{on_closed}; $params{on_closed} = sub { my ( $self ) = @_; $on_closed->( $self ) if $on_closed; $self->tangence_closed; if( my $parent = $self->parent ) { $parent->remove_child( $self ); } elsif( my $loop = $self->get_loop ) { $loop->remove( $self ); } }; } $self->SUPER::configure( %params ); } sub tangence_write { my $self = shift; $self->write( $_[0] ); } sub on_read { my $self = shift; my ( $buffref, $closed ) = @_; $self->tangence_readfrom( $$buffref ); return 0; } =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Server.pm000444001750001750 636313607230017 21550 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-2020 -- leonerd@leonerd.org.uk package Net::Async::Tangence::Server; use strict; use warnings; use IO::Async::Listener '0.36'; use base qw( IO::Async::Listener ); our $VERSION = '0.15'; use Carp; use Net::Async::Tangence::ServerProtocol; =head1 NAME C - serve C clients using C =head1 DESCRIPTION This subclass of L accepts L client connections. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item registry => Tangence::Registry The L for the server's objects. =back =cut sub _init { my $self = shift; my ( $params ) = @_; $params->{handle_constructor} = sub { my $self = shift; return Net::Async::Tangence::ServerProtocol->new( registry => $self->{registry}, on_closed => $self->_capture_weakself( sub { my $self = shift; $self->remove_child( $_[0] ); } ), ); }; $self->SUPER::_init( $params ); $self->{registry} = delete $params->{registry} if exists $params->{registry}; } sub on_accept { my $self = shift; my ( $conn ) = @_; $self->add_child( $conn ); } # Useful for testing sub make_new_connection { my $self = shift; my ( $sock ) = @_; # Mass cheating my $conn = $self->{handle_constructor}->( $self ); $conn->configure( handle => $sock ); $self->on_accept( $conn ); return $conn; } # More testing utilities sub accept_stdio { my $self = shift; my $conn = $self->{handle_constructor}->( $self ); $conn->configure( read_handle => \*STDIN, write_handle => \*STDOUT, ); $self->on_accept( $conn ); return $conn; } =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 conn_rootobj $rootobj = $server->conn_rootobj( $conn, $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 conn_rootobj { my $self = shift; return $self->{registry}->get_by_id( 1 ); } =head2 conn_permits_registry $allow = $server->conn_permits_registry( $conn ) Invoked when a C message is received from the client on the given connection object. 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 conn_permits_registry { return 1; } =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence/ServerProtocol.pm000444001750001750 271713607230017 23271 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-2020 -- leonerd@leonerd.org.uk package Net::Async::Tangence::ServerProtocol; use strict; use warnings; use base qw( Net::Async::Tangence::Protocol Tangence::Server ); use mro 'c3'; our $VERSION = '0.15'; use Carp; =head1 NAME C - C subclass for servers =head1 DESCRIPTION This subclass of L provides additional logic required by the server side of a connection. It is not intended to be directly used by server implementations. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->registry( delete $params->{registry} ); $params->{on_closed} ||= undef; $self->SUPER::_init( $params ); } sub configure { my $self = shift; my %params = @_; if( exists $params{on_closed} ) { my $on_closed = $params{on_closed}; $params{on_closed} = sub { my $self = shift; $on_closed->( $self ) if $on_closed; }; } $self->SUPER::configure( %params ); } sub rootobj { my $self = shift; my ( $identity ) = @_; return $self->parent->conn_rootobj( $self, $identity ); } sub permit_registry { my $self = shift; return $self->parent->conn_permits_registry( $self ); } =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Client000755001750001750 013607230017 21015 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Client/via000755001750001750 013607230017 21574 5ustar00leoleo000000000000Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Client/via/sshexec.pm000444001750001750 134013607230017 23727 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-2017 -- leonerd@leonerd.org.uk package Net::Async::Tangence::Client::via::sshexec; use strict; use warnings; our $VERSION = '0.15'; sub connect { my $client = shift; my ( $uri ) = @_; my $host = $uri->authority; my $path = $uri->path; # Path will start with a leading /; we need to trim that $path =~ s{^/}{}; my $query = $uri->query; defined $query or $query = ""; # $query will contain args to exec - split them on + my @argv = split( m/\+/, $query ); return $client->connect_exec( [ "ssh", $host, $path, @argv ] ); } 0x55AA; Net-Async-Tangence-0.15/lib/Net/Async/Tangence/Client/via/sshunix.pm000444001750001750 346513607230017 24000 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-2017 -- leonerd@leonerd.org.uk package Net::Async::Tangence::Client::via::sshunix; use strict; use warnings; our $VERSION = '0.15'; # A tiny program we can run remotely to connect STDIN/STDOUT to a UNIX socket # given as $ARGV[0] use constant _NC_MICRO => <<'EOPERL'; use Socket qw( AF_UNIX SOCK_STREAM pack_sockaddr_un ); use IO::Handle; socket(my $socket, AF_UNIX, SOCK_STREAM, 0) or die "socket(AF_UNIX): $!\n"; connect($socket, pack_sockaddr_un($ARGV[0])) or die "connect $ARGV[0]: $!\n"; my $fd = fileno($socket); $socket->blocking(0); $socket->autoflush(1); STDIN->blocking(0); STDOUT->autoflush(1); my $rin = ""; vec($rin, 0, 1) = 1; vec($rin, $fd, 1) = 1; print "READY"; while(1) { select(my $rout = $rin, undef, undef, undef); if(vec($rout, 0, 1)) { sysread STDIN, my $buffer, 8192 or last; print $socket $buffer; } if(vec($rout, $fd, 1)) { sysread $socket, my $buffer, 8192 or last; print $buffer; } } EOPERL sub connect { my $client = shift; my ( $uri ) = @_; my $host = $uri->authority; my $path = $uri->path; # Path will start with a leading /; we need to trim that $path =~ s{^/}{}; return $client->connect_exec( # Tell the remote perl we're going to send it a program on STDIN [ 'ssh', $host, 'perl', '-', $path ] )->then( sub { $client->write( _NC_MICRO . "\n__END__\n" ); my $f = $client->new_future; $client->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; return 0 unless $$buffref =~ s/READY//; $self->configure( on_read => undef ); $f->done; return 0; } ); return $f; }); } 0x55AA; Net-Async-Tangence-0.15/t000755001750001750 013607230017 13745 5ustar00leoleo000000000000Net-Async-Tangence-0.15/t/00use.t000444001750001750 51713607230017 15206 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( "Net::Async::Tangence::Protocol" ); use_ok( "Net::Async::Tangence::ServerProtocol" ); use_ok( "Net::Async::Tangence::Client" ); use_ok( "Net::Async::Tangence::Server" ); use_ok( "Net::Async::Tangence::Client::via::$_" ) for qw( sshexec sshunix ); done_testing; Net-Async-Tangence-0.15/t/01protocol.t000444001750001750 461313607230017 16275 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::HexString; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use Tangence::Constants; unless( VERSION_MAJOR == 0 and VERSION_MINOR == 4 ) { plan skip_all => "Tangence version mismatch"; } my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; { my $serverstream = ""; sub wait_for_message { my $msglen; wait_for_stream { length $serverstream >= 5 and length $serverstream >= ( $msglen = 5 + unpack "xN", $serverstream ) } $S2 => $serverstream; return substr( $serverstream, 0, $msglen, "" ); } } my @calls; my $stream = Testing::Protocol->new( handle => $S1, ); ok( defined $stream, 'defined $stream' ); isa_ok( $stream, "Net::Async::Tangence::Protocol", '$stream isa Net::Async::Tangence::Protocol' ); $loop->add( $stream ); $stream->minor_version( 3 ); my $message; $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; $expect = "\1" . "\0\0\0\x09" . "\x02" . "\x01" . "\x26" . "method"; is_hexstr( wait_for_message, $expect, 'serverstream after initial MSG_CALL' ); $S2->syswrite( "\x82" . "\0\0\0\x09" . "\x28" . "response" ); wait_for { defined $response }; is( $response->code, MSG_RESULT, '$response->code to initial call' ); is( $response->unpack_str, "response", '$response->unpack_str to initial call' ); $S2->syswrite( "\x04" . "\0\0\0\x08" . "\x02" . "\x01" . "\x25" . "event" ); wait_for { @calls }; 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' ); $message = Tangence::Message->new( $stream, MSG_OK ); $c->[0]->respond( $c->[1], $message ); $expect = "\x80" . "\0\0\0\0"; is_hexstr( wait_for_message, $expect, '$serverstream after response' ); done_testing; package Testing::Protocol; use strict; use base qw( Net::Async::Tangence::Protocol ); sub handle_request_EVENT { my $self = shift; my ( $token, $message ) = @_; push @calls, [ $self, $token, $message ]; return 1; } Net-Async-Tangence-0.15/t/02server.t000444001750001750 626713607230017 15752 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::HexString; use Test::Memory::Cycle; use Test::Refcount; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::Conversation; use t::TestObj; unless( VERSION_MAJOR == 0 and VERSION_MINOR == 4 ) { plan skip_all => "Tangence version mismatch"; } use Net::Async::Tangence::Server; $Tangence::Message::SORT_HASH_KEYS = 1; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); 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' ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); is_oneref( $server, '$server has refcount 1 initially' ); $loop->add( $server ); is_refcount( $server, 2, '$server has refcount 2 after $loop->add' ); my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; { my $serverstream = ""; sub wait_for_message { my $msglen; wait_for_stream { length $serverstream >= 5 and length $serverstream >= ( $msglen = 5 + unpack "xN", $serverstream ) } $S2 => $serverstream; return substr( $serverstream, 0, $msglen, "" ); } } my $conn = $server->make_new_connection( $S1 ); is_refcount( $server, 2, '$server has refcount 2 after new BE' ); # Three refs: one in Server, one in IO::Async::Loop, one here is_refcount( $conn, 3, '$conn has refcount 3 initially' ); # Initialisation { $S2->syswrite( $C2S{INIT} ); is_hexstr( wait_for_message, $S2C{INITED}, 'serverstream initially contains INITED message' ); is( $conn->minor_version, 4, '$conn->minor_version after MSG_INIT' ); $S2->syswrite( $C2S{GETROOT} ); is_hexstr( wait_for_message, $S2C{GETROOT}, 'serverstream contains root object' ); # lexical $obj + 2 smashed properties is_refcount( $obj, 3, '$obj has refcount 3 after MSG_GETROOT' ); is( $conn->identity, "testscript", '$conn->identity' ); $S2->syswrite( $C2S{GETREGISTRY} ); is_hexstr( wait_for_message, $S2C{GETREGISTRY}, 'serverstream contains registry' ); } # Methods { $S2->syswrite( $C2S{CALL} ); is_hexstr( wait_for_message, $S2C{CALL}, 'serverstream after response to CALL' ); } # That'll do; everything should be tested by Tangence itself # lexical $obj + 2 smashed properties is_refcount( $obj, 3, '$obj has refcount 3 before shutdown' ); is_refcount( $server, 2, '$server has refcount 2 before $loop->remove' ); $loop->remove( $server ); is_oneref( $server, '$server has refcount 1 before shutdown' ); { 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' ); # Can't easily do $server yet because Devel::Cycle will throw # Unhandled type: GLOB at /usr/share/perl5/Devel/Cycle.pm line 107. # on account of filehandles } $conn->close; undef $server; is_oneref( $conn, '$conn has refcount 1 after shutdown' ); done_testing; Net-Async-Tangence-0.15/t/03client.t000444001750001750 442613607230017 15716 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal qw( dies_ok ); use Test::HexString; use Test::Memory::Cycle; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use Tangence::Constants; use Tangence::Registry; use lib "."; use t::Conversation; use Net::Async::Tangence::Client; $Tangence::Message::SORT_HASH_KEYS = 1; unless( VERSION_MAJOR == 0 and VERSION_MINOR == 4 ) { plan skip_all => "Tangence version mismatch"; } my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; { my $clientstream = ""; sub wait_for_message { my $msglen; wait_for_stream { length $clientstream >= 5 and length $clientstream >= ( $msglen = 5 + unpack "xN", $clientstream ) } $S2 => $clientstream; return substr( $clientstream, 0, $msglen, "" ); } } my $client = Net::Async::Tangence::Client->new( handle => $S1, on_error => sub { die "Test died early - $_[0]" }, identity => "testscript", ); $loop->add( $client ); # Initialisation { is_hexstr( wait_for_message, $C2S{INIT}, 'client stream initially contains MSG_INIT' ); $S2->syswrite( $S2C{INITED} ); is_hexstr( wait_for_message, $C2S{GETROOT}, 'client stream contains MSG_GETROOT' ); $S2->syswrite( $S2C{GETROOT} ); wait_for { defined $client->rootobj }; is_hexstr( wait_for_message, $C2S{GETREGISTRY}, 'client stream contains MSG_GETREGISTRY' ); $S2->syswrite( $S2C{GETREGISTRY} ); wait_for { defined $client->registry }; } my $objproxy = $client->rootobj; # Methods { my $f = $objproxy->call_method( method => 10, "hello", ); is_hexstr( wait_for_message, $C2S{CALL}, 'client stream contains MSG_CALL' ); $S2->syswrite( $S2C{CALL} ); wait_for { $f->is_ready }; is( scalar $f->get, "10/hello", 'result of call_method()' ); } # That'll do; everything should be tested by Tangence itself memory_cycle_ok( $objproxy, '$objproxy has no memory cycles' ); # Deconfigure the clientection otherwise Devel::Cycle will throw # Unhandled type: GLOB at /usr/share/perl5/Devel/Cycle.pm line 107. # on account of filehandles $client->configure( handle => undef ); memory_cycle_ok( $client, '$client has no memory cycles' ); done_testing; Net-Async-Tangence-0.15/t/04xlink.t000444001750001750 342013607230017 15557 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal qw( dies_ok ); use Test::Memory::Cycle; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use Tangence::Constants; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::TestObj; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; my $conn = $server->make_new_connection( $S1 ); my $client = Net::Async::Tangence::Client->new( handle => $S2 ); $loop->add( $client ); wait_for { defined $client->rootobj }; my $objproxy = $client->rootobj; # Methods { my $f = $objproxy->call_method( method => 10, "hello", ); wait_for { $f->is_ready }; is( scalar $f->get, "10/hello", 'result of call_method()' ); } # That'll do; everything should be tested by Tangence itself { 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' ); memory_cycle_ok( $objproxy, '$objproxy has no memory cycles' ); # Deconfigure the connection otherwise Devel::Cycle will throw # Unhandled type: GLOB at /usr/share/perl5/Devel/Cycle.pm line 107. # on account of filehandles $client->configure( handle => undef ); memory_cycle_ok( $client, '$client has no memory cycles' ); } done_testing; Net-Async-Tangence-0.15/t/05close.t000444001750001750 353213607230017 15544 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use Tangence::Constants; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::Ball; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $registry = Tangence::Registry->new( tanfile => "t/Ball.tan", ); my $ball = $registry->construct( "t::Ball", colour => "red", size => 100, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); my ( $conn1, $conn2 ) = map { my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; my $conn; my $serverconn = $server->make_new_connection( $S1 ); my $client = Net::Async::Tangence::Client->new( handle => $S2 ); $loop->add( $client ); my $ballproxy; wait_for { $ballproxy = $client->rootobj }; $conn = { server => $serverconn, client => $client, ballproxy => $ballproxy, }; my $f = $ballproxy->watch_property( "colour", on_set => sub { $conn->{colour} = shift }, ); wait_for { $f->is_ready }; $f->get; $conn } 1 .. 2; $ball->set_prop_colour( "green" ); wait_for { defined $conn1->{colour} and defined $conn2->{colour} }; is( $conn1->{colour}, "green", '$colour is green from connection 1' ); is( $conn2->{colour}, "green", '$colour is green from connection 2' ); $conn1->{client}->close; $loop->loop_once( 0 ) for 1 .. 10; # ensure the close event is properly flushed $ball->set_prop_colour( "blue" ); undef $_->{colour} for $conn1, $conn2; wait_for { defined $conn2->{colour} }; is( $conn1->{colour}, undef, '$colour is still undef from (closed) connection 1' ); is( $conn2->{colour}, "blue", '$colour is blue from connection 2' ); done_testing; Net-Async-Tangence-0.15/t/20connect-exec.t000444001750001750 105513607230017 17005 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use IO::Async::Test; use IO::Async::Loop; use Net::Async::Tangence::Client; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $client = Net::Async::Tangence::Client->new; $loop->add( $client ); my $serverpath = "t/server.pl"; eval { $client->connect_url( "exec:///$serverpath" )->get; 1; } or plan skip_all => "Unable to exec $serverpath"; pass "Connected via EXEC"; wait_for { defined $client->rootobj }; ok( defined $client->rootobj, "Negotiated rootobj" ); done_testing; Net-Async-Tangence-0.15/t/20connect-sshexec.t000444001750001750 160513607230017 17524 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { $ENV{CAN_SSH_LOCALHOST} or plan skip_all => 'set CAN_SSH_LOCALHOST=1 to test ssh to localhost'; open( my $sshfd, "-|", qw( ssh localhost perl -e ), q('print "YES\n"') ) or plan skip_all => "Unable to ssh localhost and exec perl"; <$sshfd> eq "YES\n" or plan skip_all => "Received incorrect response from ssh perl"; } use File::Spec; use IO::Async::Test; use IO::Async::Loop; use Net::Async::Tangence::Client; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $client = Net::Async::Tangence::Client->new; $loop->add( $client ); my $serverpath = File::Spec->rel2abs( "t/server.pl" ); $client->connect_url( "sshexec://localhost/$serverpath" )->get; pass "Connected via SSHEXEC"; wait_for { defined $client->rootobj }; ok( defined $client->rootobj, "Negotiated rootobj" ); done_testing; Net-Async-Tangence-0.15/t/20connect-sshunix.t000444001750001750 266213607230017 17567 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { $ENV{CAN_SSH_LOCALHOST} or plan skip_all => 'set CAN_SSH_LOCALHOST=1 to test ssh to localhost'; open( my $sshfd, "-|", qw( ssh localhost perl -e ), q('print "YES\n"') ) or plan skip_all => "Unable to ssh localhost and exec perl"; <$sshfd> eq "YES\n" or plan skip_all => "Received incorrect response from ssh perl"; } use File::Spec; use IO::Async::Test; use IO::Async::Loop; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::TestObj; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $client = Net::Async::Tangence::Client->new; $loop->add( $client ); my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); my $path = "t/test.sock"; END { unlink $path if -e $path } eval { $server->listen( addr => { family => "unix", path => $path } )->get; 1; } or plan skip_all => "Unable to listen on unix socket"; my $serverpath = File::Spec->rel2abs( $path ); $client->connect_url( "sshunix://localhost/$serverpath" )->get; pass "Connected via SSHUNIX"; wait_for { defined $client->rootobj }; ok( defined $client->rootobj, "Negotiated rootobj" ); done_testing; Net-Async-Tangence-0.15/t/20connect-tcp.t000444001750001750 200513607230017 16643 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use IO::Async::Test; use IO::Async::Loop; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::TestObj; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); eval { $server->listen( addr => { family => "inet" } )->get; 1; } or plan skip_all => "Unable to listen on inet socket"; my $host = $server->read_handle->sockhost; my $port = $server->read_handle->sockport; my $client = Net::Async::Tangence::Client->new; $loop->add( $client ); $client->connect_url( "tcp://${host}:${port}/" )->get; pass "Connected via TCP"; wait_for { defined $client->rootobj }; ok( defined $client->rootobj, "Negotiated rootobj" ); done_testing; Net-Async-Tangence-0.15/t/20connect-unix.t000444001750001750 177213607230017 17052 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use IO::Async::Test; use IO::Async::Loop; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::TestObj; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); my $path = "t/test.sock"; END { unlink $path if -e $path } eval { $server->listen( addr => { family => "unix", path => $path } )->get; 1; } or plan skip_all => "Unable to listen on unix socket"; my $client = Net::Async::Tangence::Client->new; $loop->add( $client ); $client->connect_url( "unix:///$path" )->get; pass "Connected via UNIX"; wait_for { defined $client->rootobj }; ok( defined $client->rootobj, "Negotiated rootobj" ); done_testing; Net-Async-Tangence-0.15/t/90close-leak.t000444001750001750 241213607230017 16456 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "No Test::MemoryGrowth" unless eval { require Test::MemoryGrowth }; } use Test::MemoryGrowth; use IO::Async::Test; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use Tangence::Constants; use Tangence::Registry; use Net::Async::Tangence::Server; use Net::Async::Tangence::Client; use lib "."; use t::Ball; my $loop = IO::Async::Loop->new(); testing_loop( $loop ); my $registry = Tangence::Registry->new( tanfile => "t/Ball.tan", ); my $ball = $registry->construct( "t::Ball", colour => "red", size => 100, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); no_growth { my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; $server->make_new_connection( $S1 ); my $client = Net::Async::Tangence::Client->new( handle => $S2 ); $loop->add( $client ); my $ballproxy; wait_for { $ballproxy = $client->rootobj }; my $f = $ballproxy->watch_property( "colour", on_set => sub {}, ); wait_for { $f->is_ready }; $f->get; $client->close; $loop->loop_once( 0 ); } calls => 100, 'Connect/watch/disconnect does not grow memory'; done_testing; Net-Async-Tangence-0.15/t/99pod.t000444001750001750 25713607230017 15217 0ustar00leoleo000000000000#!/usr/bin/perl use strict; 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(); Net-Async-Tangence-0.15/t/Ball.pm000444001750001750 114413607230017 15312 0ustar00leoleo000000000000package t::Ball; use strict; use base qw( Tangence::Object t::Colourable ); use Tangence::Constants; sub new { my $class = shift; my %args = @_; my $self = $class->SUPER::new( %args ); $self->set_prop_colour( $args{colour} ); $self->set_prop_size( $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 { my $self = shift; my ( $ctx, $howhigh ) = @_; $last_bounce_ctx = $ctx; $self->fire_event( "bounced", $howhigh ); return "bouncing"; } 1; Net-Async-Tangence-0.15/t/Ball.tan000444001750001750 24013607230017 15434 0ustar00leoleo000000000000include "Colourable.tan" class t.Ball { isa t.Colourable; method bounce(str howhigh) -> str; event bounced(str howhigh); smashed prop size = int; } Net-Async-Tangence-0.15/t/Colourable.pm000444001750001750 10213607230017 16500 0ustar00leoleo000000000000package t::Colourable; use strict; use Tangence::Constants; 1; Net-Async-Tangence-0.15/t/Colourable.tan000444001750001750 5413607230017 16634 0ustar00leoleo000000000000class t.Colourable { prop colour = str; } Net-Async-Tangence-0.15/t/Conversation.pm000444001750001750 1761513607230017 17144 0ustar00leoleo000000000000package t::Conversation; use strict; 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"; Net-Async-Tangence-0.15/t/TestObj.pm000444001750001750 335613607230017 16021 0ustar00leoleo000000000000package t::TestObj; use strict; use base qw( Tangence::Object ); use Tangence::Constants; sub new { my $class = shift; my %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 { my $self = shift; my ( $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 { my $self = shift; my ( $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 { my $self = shift; my ( $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; Net-Async-Tangence-0.15/t/TestObj.tan000444001750001750 73113607230017 16141 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; } Net-Async-Tangence-0.15/t/server.pl000555001750001750 130013607230017 15742 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; BEGIN { use File::Basename qw( dirname ); # this script lives in SRCDIR/t/server.pl # chdir to SRCDIR chdir dirname( dirname( $0 ) ); } use blib; use IO::Async::Loop; use Tangence::Registry; use Net::Async::Tangence::Server; use lib "."; use t::TestObj; my $loop = IO::Async::Loop->new(); my $registry = Tangence::Registry->new( tanfile => "t/TestObj.tan", ); my $obj = $registry->construct( "t::TestObj", scalar => 123, s_scalar => 456, ); my $server = Net::Async::Tangence::Server->new( registry => $registry, ); $loop->add( $server ); $server->accept_stdio ->configure( on_closed => sub { $loop->stop } ); $loop->run;