Event-RPC-1.10/0000755000175000017500000000000013314763036012160 5ustar joernjoernEvent-RPC-1.10/Changes0000644000175000017500000002273313314763015013457 0ustar joernjoernRevision history and release notes for Event::RPC: 1.10 Wed Jun 27, 2018, joern Bugfixes: - Test suite failed on newer Perl versions which do not have . in @INC anymore. 1.09 Mon Jun 25, 2018, joern Features: - Event::RPC::Server->prepare() to support having control over the Event loop yourself. Bugfixes: - SSL tests failed due to expired CA certificate. Just created new certificates with 30 year expiration and put a gen.sh script inside to easily generate new certificates after that period ;) - Removed unused code. Thanks for the hint to ppisar AT redhat.com. 1.08 Sun Sep 26, 2015, joern Notes: - Just a stable release without changes. 1.08_01 Sat Sep 26, 2015, joern Features: - Support for multiple serialisers: Sereal, CBOR::XS, JSON::XS and Storable. That's because Storable is known to be insecure, so this module should not rely on it. Great care has been taken to make these changes up- and downwards compatible, so old clients still can connect to new servers and vice versa. Check documentation chapters MESSAGE FORMAT OPTIONS in Event::RPC, Event::RPC::Server and Event::RPC::Client manpages for details. Thanks to mala for his hint about the security issues of Storable. You find more details in this article: http://www.masteringperl.org/2012/12/the-storable-security-problem/ Bugfixes: - Proper handling of exceptions which occur at the server before a remote method is really executed, e.g. when lookup of the class failed due to incorrect @INC path. - Fixed encoding of source files and corrected the year of all Copyright notices. 1.07 Mon Sep 21, 2015, joern Features: - New method return type '_singleton'. Objects created this way are never destroyed on the server. 1.06 Sun Sep 20, 2015, joern Features: - New 'ssl_opts' attribute for Server and Client to give more control over the SSL connection. Bugfixes: - Some tests failed due to stronger hostname verifcation in IO::Socket:SSL >= 2.017. Fixed that by adding proper certificates with cn 'localhost' and a test which verifies the failing connection with wrong hostname. Thanks to ppisar AT redhat.com. This fixes rt #106874. 1.05 Tue Feb 28, 2014, joern Features: - New Method set_max_packet_size (Client and Server) to change the default value of 2 GB up to 4 GB (or less). Bugfixes - Increased default maximum packet size from 4 MB to 2 GB. - Fixed test suite for parallel execution by using different port numbers for the test server. Thanks for the report to Andreas König. - Applied a patch from Salvatore Bonaccorso which fixes missing encoding declarations in POD. Thanks! - Fixed some POD typos. Thanks for the report to Xavier Guimard. 1.04 Fri Feb 24, 2014, joern Bugfixes - Under certain infrequently conditions it could happen that the server process blocked when sending a response packet to a client. - Event::RPC::Client failed loading when no IO::Socket::SSL is installed. 1.03 Sat Feb 2, 2013, joern Features: - Added options 'ssl_ca_file and 'ssl_ca_path' options to Event::RPC::Client, which enable SSL peer verifcation on the client. Thanks for the report about a security warning of IO::Socket::SSL to Moritz Bunkus. 1.02 Tue Mar 8, 2011, joern Features: - Added AnyEvent mainloop implementation. 1.01 Sat Oct 25, 2008, joern Bugfixes: - Even objects returned by methods not declared as an "object returner" where turned into Event::RPC object handles instead of copying the complete data structure to the client. Thanks for the report to Alex . 1.00 Sat Jun 21, 2008, joern Notes: - Time for version 1.00 ;) Features: - load_modules option added to Event::RPC::Server. - timeout option added to Event::RPC::Client. Patch by Strzelecki Lukasz . 0.90 Sun Apr 23, 2006, joern Notes: - Just a change to the license, switched from LGPL to Perl Artistic + GPL. Thanks for the hint about the bad wording in the old license text to Gregor Herrmann. 0.89 Mon Mar 27, 2006, joern Features: - New class_map attribute for Event::RPC::Client to be able to use classes locally which are imported from the server as well, by giving the server classes a different name on the client. - Turn execptions of unregistered object access into warnings, which makes client / server communication more robust and debugging easier. Bugfixes: - Fixed crashing when a method declared as an object returner returned undef, which should be absolutely legal. - Fixed client side exceptions if server connection is unexpectedly interrupted during a remote method call. - Exceptions are now stringified before send to the client, otherwise Storable may complain on exception objects which can't be freezed e.g. due to embedded code refs. 0.88 Sat Dec 24, 2005, joern Bugfixes: - Use Storable::nfreeze() to pack network messages, so Event::RPC works with mixed endian architectures as well. Patch by Rolf Grossmann . 0.87 Sun Dec 18, 2005, joern Features: - Delegation of authentication resp. user/password check to an external module via Event::RPC::Server attribute "auth_module". Old passwd hash based model is implemented in Event::RPC::AuthPasswdHash. - Fixed a typo in Event::RPC::Looger manpage. Thanks to Sean for the report. - Cleaned up examples/: server.pl and client.pl now both accept -h option for binding/connecting to a specific host, not just localhost. - Makefile.PL tuning: add detected optional modules to PREREQ_PM to get their version numbers added to CPAN Testers reports. Bugfixes: - ChangeLog entry 0.86 was wrong regarding the SSL stuff. 0.86 Sat Dec 17, 2005, joern Features: - added Event::RPC::Server->get_active_connection - documented Event::RPC::Connection->get_client_oids - added Event::RPC::Connection->get_client_object Bugfixes: - Added missing documentation for Event::RPC::Client's error_cb attribute, which was just mentioned in the SYNPOSIS. - Fixed an incompatability with IO::Socket::SSL 0.97, which doesn't return different sysread() states for error and eof anymore which confused Event::RPC. 0.85 Sun Aug 28, 2005, joern Bugfixes: - Make server more bullet proof: handle log connections even if no logger is set, but a log listener was started. - Event::RPC::Server->new didn't recognize the 'connection_hook' parameter. - Try making the testsuite more stable with Win32. 0.84 Mon Jul 25, 2005, joern Bugfixes: - Buffering for big incoming RPC requests (> 64KB) didn't work properly 0.83 Fri Apr 15, 2005, joern Features: - Made more parts of the API public by documenting them. - New server option "connection_hook" for accessing Event::RPC::Connection objects during connecting and disconnecting. - New server option "auto_reload_modules" to control the server's auto reloading facility, which was activated by default up to now. - New server option "host" to bind the listener to a specific address. Default is to bind to all addresses. - Increased connect performance by reducing the number of messages exchanged between client and server. - Client may request a subset of exported server classes. Default is still to import all classes exported by the server. - Client checks Event::RPC version and used protocol version on connect and warns different software versions but dies on incompatible protocol versions. Naturally it's recommended to use the same Event::RPC version on server and client. - Methods for getting client and server (after connecting) software and protocol version numbers. Bugfixes: - Missed ReuseAddr on listener sockets. - Made testsuite more robust - Network logging clients could block the server by sending data to it. - Renamed client option 'server' to 'host', which is more adequate. 'server' is still allowed but deprecated and using it triggers a warning. 0.82 Sun Apr 10, 2005, joern Notes: - First public release. API is fairly stable. Features: - User/password based authentication added. - Full documentation added. - Test suite added which covers all connection types and the most important features. 0.81 Sun Mar 13, 2005, joern Notes: - Still an internal release, incomplete documentation, no test suite. Features: - Support for SSL encryption added using IO::Socket::SSL. - Event loop abstraction. Event::RPC now works with Event and Glib and can be easily extended for other event loop frameworks. Thanks to Rocco Caputo for the suggestion. 0.80 Sun Mar 13, 2005, joern Notes: - A non public release. Only announced on the perl-loop mailing list for the namespace request and to get comments. Module is fully working but API isn't documented yet very well. Security stuff (SSL encryption, some password authentication) is missing also a complete test suite. Event-RPC-1.10/t/0000755000175000017500000000000013314763036012423 5ustar joernjoernEvent-RPC-1.10/t/ssl/0000755000175000017500000000000013314763036013224 5ustar joernjoernEvent-RPC-1.10/t/ssl/ca-wrong.key0000644000175000017500000000321313314245553015451 0ustar joernjoern-----BEGIN RSA PRIVATE KEY----- MIIEogIBAAKCAQEA3EQ1cONlfwmxvIjA7VNIRuGCXiODWJ2hbFnZPIpleQKfBKG+ 3dOzQCaPWxmxLflxzfC1wSfSMXArCEOcgV9KvNNLvR4FAWa0SizK+DZcYA1B4NlP dwV3+c7y+ELx+vya5ZtAtrbvfkE+cxtU4xjgFoHVd8LsCoobnGPzcYlOVBn3uIqB CNpIXwtHo2u8TZ1d4VLNLyzscTV3sS+rD5rg3AtBfYhaK8KqH5zMTuV0DWNPDcOs o1SlSoTvV8sM2Db02eCyxE7pFqnhyVGsFHwX/LDcwGQf9aBFMK6HhVwbRb9dMZ2h D6kMZRSLouLBEszHeWCtE0KY3vkkFdJCiVEgQQIDAQABAoIBAQCH4FvHI7+8ulI2 J3Y78KApeXtebzHbPIITwOlNe2JVX9SQmuaPGMT+0cqlPBgccEBP9ilo2hPEA5nI I00sUYhdK0sRgq87ygt1pmQe8gnSBtuYxPVMSsdUBuHDXCjB14oGEdu92uOqUr0f bMDUxseVmsoAcvIBHmkh9FZ8t2LmZWi9D08KrzbcSyrNjHGTh/rkSADKvSPnCiRB HatyiBLP81OhqdnEi5VMqpSBkrGbWaCL+1nHX9u8U6mj64ODqP9YKbiz0byBFH1i SeVwDGVBfJTJlJqK8bZyiTQoK1v8+Gs/UM/4nlMeQm+BWARYiwTNfMRx5VX7Yfn+ Vse94FdxAoGBAP8gynkuebqpMAwk61XDK4k0v9IrKX+JGn/+bfb0br7wC0lo8VtW V/PF45J5Lqo2MHoVZZjcj7GORLxwLERjIrfVkc4+b/H0N8DZqT3c2IWjI65T9v4J 75/XKZJJN+gb9ArzS4EWFQjNXPzpKTVfUaRu9q0K3PwqNFtz3ssRugWrAoGBAN0E 6u/0hxgv4OlseNupg3HDRqHXHkHlnDNTz7tzRQW7BoGvvuric+Uhq9hEQTdtGa5O 113YsSAI2XO5abJzoc7uAw1eaxVPEbYBRCEnficLWWt6X66ZxkSd4m4fF5XEUuFu Ckvi5OqdVIkNng2VpcHMrWnkHVLxjvnrur3tn23DAoGBAL16fAWOF8gi2VVbohBa 2B2ZuJD9j19x0uWWb9MGbK2QF8HYl9BPCxk4MjDZoWe2wUAaXg8uV+X1lGUjJi1Q Nzuy+Qvk4T0gNLwcq44PVBvEMr7JC1pWxMnAgdZsXIIdKJ1tXfksDkkwRExtWjaS aU8nPjr8I22AZsw4/RFyQ+brAoGAVqow/Xpi5scPaDhSg7/KfPdXYOqbQLeqMi4x DI28iOy3Nm8Va8D0NOqpGZpaAEPViBX+ORxZB/iwW8Jegcz5q8yEgd9+GdLxXO7O Kjn0K5c1rwFDN5GwvwMx4IBsnRtobGDbxLnpjV234i3mxejiIEYD0bvTC80QhUs7 5HGizEUCf3+iVFIMduxQGhTiGuPfWkfDVtvzC30snhPb5Dd5LwxoaJJZ9X5RTawx DrjeiGHuMiWWRHD5Py3FbT4nU4Ishi1QEGwXc33T1YfCNbaJ3chheE9LVh5/s2qd Q50nfQ9Gc00/2hpHLk4Kp56C2DU5/pynph0O7BIakjZwxqy8f4o= -----END RSA PRIVATE KEY----- Event-RPC-1.10/t/ssl/ca.crt0000644000175000017500000000241613314245553014323 0ustar joernjoern-----BEGIN CERTIFICATE----- MIIDjjCCAnagAwIBAgIJAMvmJmdslZBCMA0GCSqGSIb3DQEBCwUAMFwxCzAJBgNV BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX aWRnaXRzIFB0eSBMdGQxFTATBgNVBAsMDEV2ZW50LVJQQyBDQTAeFw0xODA2MjUx OTUwNDFaFw00ODAxMTkxOTUwNDFaMFwxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApT b21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQxFTAT BgNVBAsMDEV2ZW50LVJQQyBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC ggEBAMPMqmDyNhrcAx5dpxIsAAw73PasLhp6u8HaHiCjqMEkypdxuMdj2Dmvq3dw XLFiLQRZ6JE8KYEVZh4tdFtTCdhVhVQlLirh2ikMHw108bZ2Qfzfk5I9N8maU62e UyPu8b2uD9Yj5MlqutZUMVZbdcRDkNDXVBPgN7xCpF7CTj8ThV09jWJ3ooH+ws7L r2SQK2tyf/yvlewKd47l3PV8kdNphJOxmB+sowfXBVlFn3lP0rbc9gxfaHDlSPU/ 4rJUTRKMlcW58K5WNMMVKDOldd8gMURZUfuivaaxqjpi0tagp6knFgmNVxCRaP/b sZw6MlXPbX4VHLF8Khsm3RjLgvsCAwEAAaNTMFEwHQYDVR0OBBYEFK9zeftPaP6k IEZ79TWosaXTHkj+MB8GA1UdIwQYMBaAFK9zeftPaP6kIEZ79TWosaXTHkj+MA8G A1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEBACnVfIrMoLaDEFw1xY2j se3977thZlXXemaEFrzTP6AXacTkigLrDayUUheUOtdz85i/XoDMyzCwGYjx/oNX z8tz76iJoijarVg043RIoasDtsF7ECBurrfAW5tnXNkiI1ZYXy2VaPqt3lJKNnGS DYR5iRHWudbrFamTsTaqViDFRqQGt94uPCfdT9AJlCMSwMXDrKVCJWn8AC4HLpA6 MRYIwLr6jr8BXdFjuyZnA02HOSliJdernrjCAKsgnkssjWFgkPW70b8SnlIEelrk wr56T5C3FQg/GtlWtGGQIUjvHJSNmtIiBfikhKynXynrP+AIrz97KNh1XieoYi88 SSY= -----END CERTIFICATE----- Event-RPC-1.10/t/ssl/ca-wrong.crt0000644000175000017500000000240113314245553015447 0ustar joernjoern-----BEGIN CERTIFICATE----- MIIDhjCCAm6gAwIBAgIJAKVEUkY550gjMA0GCSqGSIb3DQEBCwUAMFgxCzAJBgNV BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX aWRnaXRzIFB0eSBMdGQxETAPBgNVBAsMCEFsaWVuIENBMB4XDTE4MDYyNTE5NTA0 MVoXDTQ4MDExOTE5NTA0MVowWDELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUt U3RhdGUxITAfBgNVBAoMGEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDERMA8GA1UE CwwIQWxpZW4gQ0EwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDcRDVw 42V/CbG8iMDtU0hG4YJeI4NYnaFsWdk8imV5Ap8Eob7d07NAJo9bGbEt+XHN8LXB J9IxcCsIQ5yBX0q800u9HgUBZrRKLMr4NlxgDUHg2U93BXf5zvL4QvH6/Jrlm0C2 tu9+QT5zG1TjGOAWgdV3wuwKihucY/NxiU5UGfe4ioEI2khfC0eja7xNnV3hUs0v LOxxNXexL6sPmuDcC0F9iForwqofnMxO5XQNY08Nw6yjVKVKhO9XywzYNvTZ4LLE TukWqeHJUawUfBf8sNzAZB/1oEUwroeFXBtFv10xnaEPqQxlFIui4sESzMd5YK0T Qpje+SQV0kKJUSBBAgMBAAGjUzBRMB0GA1UdDgQWBBQMkBsvBfTFdk/ndEVrpM/l e5DSUDAfBgNVHSMEGDAWgBQMkBsvBfTFdk/ndEVrpM/le5DSUDAPBgNVHRMBAf8E BTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQB9elXbFCm+WXARJ+lMXt6ltHfg85Kz aV/fjrpkhphlf9i3NRzxFTrm82EOduUZpCi2TzeR3bU5Jq8lpKPsyYoqlJMFPVZR PW2iq3Dq+lyK0GVytI7NviU/9IKycAgugXzFSjgG3jVRFmNp8wuGNfBg6Hc3coeh OFjkDE6OqrtIhAYZSDcPANiraM8y0Ib52zBdJmBFa2yqoJ5hsYsqNxXGDLQnnci0 IoudiW8+5k5OQXG9eWXibfrqHr3izf/bGVLDoRpwDDHkB/a7uRfmxUUVch/q+KiI pFKpih0ey+mPCSljg3yDJUJ6LHdPaPscH863Uq2pXejOcV8Ly/xgsk8+ -----END CERTIFICATE----- Event-RPC-1.10/t/ssl/ca.key0000644000175000017500000000321713314245553014323 0ustar joernjoern-----BEGIN RSA PRIVATE KEY----- MIIEpAIBAAKCAQEAw8yqYPI2GtwDHl2nEiwADDvc9qwuGnq7wdoeIKOowSTKl3G4 x2PYOa+rd3BcsWItBFnokTwpgRVmHi10W1MJ2FWFVCUuKuHaKQwfDXTxtnZB/N+T kj03yZpTrZ5TI+7xva4P1iPkyWq61lQxVlt1xEOQ0NdUE+A3vEKkXsJOPxOFXT2N Yneigf7CzsuvZJAra3J//K+V7Ap3juXc9XyR02mEk7GYH6yjB9cFWUWfeU/Sttz2 DF9ocOVI9T/islRNEoyVxbnwrlY0wxUoM6V13yAxRFlR+6K9prGqOmLS1qCnqScW CY1XEJFo/9uxnDoyVc9tfhUcsXwqGybdGMuC+wIDAQABAoIBAAj2fXYioEdqetoQ /2zdhsMImnzQNOwRYjblfSuRUlBFFuEH26WE9IjvebHl+thD3juswfCkCGJYUGxh OEpV6sV0ZL4NVaew3wOyAlnjWI05rJuewGqZUsxvvBTegn/KmFZOeXsb+YUe1Z6q C/ggB6wMS7zDnp2qTeLYSh3sVxib/5h96PgR3lwOxg6VAG554DU7xFR7ZLEAk1d0 35kcXkzD1+5LIYO2u7ArtubS8l3OD95x40Coa/xiptWu4MehpJ8aBwFNVc9wtODi ylgJogBJCEv1Kumf1zhqcytHURi8k5raD9im/7Zs7XAxywZMRkb8JnyF5s+r81Iy JWCxRkECgYEA8YBOLCXqM0JT9Js4+itTnN+whN/JBVwDnbtW9c3LT7IeAOqvN2WT wrXqRKyuJJ26WG+N2IiO5lWTYuV0RLggEmmPbwLgR3zCpBscIS8vtjpzmcczV4Ps JkzPM/WyMUEJqdGU9tpxIktoYMat768iQ9BKfG+WGEKOCqursx9zp8UCgYEAz431 ZjAFt8nPfTCU1w9loQ3O0XLwtF5s4VU/HJM3HHyW47vc2PmQZNnTkrgKEPrzM5RM 7CVK/fEcYDr/oYSUH0o2qC8GHCglSYXeILepdRGkWZ9/gQ5Y/mlxhB2Q2ux8rgTT bXWF/QLjEga6HLaKOrO7xU75nOAEZTnEPuT6a78CgYB4kIN2St9nA8ACJ9QEIMk3 Uf0/+LDUuiEcB8DcKgdMHDIaZw9eapmf5U21RzgRE6VKLTb1WQduOl7ASqkG/Z0V VBnFY/wv9Dr/zoD2mCYLpZa8uNQK5tNoM4Rl/k0dhcibPQRPULKWWmsblVSUiixj CoOFJ/gY2HEtJpMrc5I7uQKBgQDFd7pSTr4h7c+Ku/3f3rZCVHDAtSptcKkGeaRh +24jnCWy5blodYf7a4LvxElPfnKEUEQfKBwBHrRwmbE8anbCjkkSGisl/sv693Iu jo6a4v4KhsU4c/4XjxqBJ9/5aaX1qoG9UmL4JRcEv4Gyb7lzwCyVvF2f80I7TIp5 jED04QKBgQC20J5pOZTRKxXWyBmW0ZLsRXqUA4RAdYxyZE+GlRf5SbnThVhymdaF +21vCUeC1PoBDkG8H2wa0dMZKTYjX8pW9nCHIUU0FzIhPcoqsUHR9v2yO/7xVI9/ Exbv3Qe27nnIg+gQew0UPhsK946osotsdXTwWyGRVqCd2HnHaAilCg== -----END RSA PRIVATE KEY----- Event-RPC-1.10/t/ssl/server.key0000644000175000017500000000321713314245553015246 0ustar joernjoern-----BEGIN RSA PRIVATE KEY----- MIIEpAIBAAKCAQEAsdC8kDOOoSnxFSF0SzEO3qHb4I4zRVmhSXGVVlb33IH4C/kQ 9jqLWeyfOs/infAuL+D7iA4qztb3scdQhs11jr4XEaV8s9fDfrKEljed759IOhGQ nMPDFiytUSkSV0O+XaOugkIrAk2aHNkSRuMf1ERi5mw4jQXeAAMy2xUdzQEOZaRT A7mviANSOhuApfyp9xz98fSnzmkbg1yq0qTV942bFvs6S9YijTXI/QUuNIyIVVAT IeZ3quVQ5UWk9rH5laiMZ6mNbPQJOJHOGhfckjoXYeSiprYXTKYtrDslJbgEQKuv aGkhB0qIBoSnqV0Wua/+6OUIX7b+1BcGKgpCqwIDAQABAoIBAEZ3poKvK/MKoBPz shaqVm48Ttrq/76YCqcEcF5LEOc+SoLULbim8tqsP14bTH+y01r+GjCNDMHzxy2Z A3yop9Ht206O+qB6/WqUbJ7rY5e20/TPSTQXEJUVF4p2cGJM4oBRgbL1bf33qv+L twaIs/B3OYp/kNmyXYw7uEfCUpEPFLWSK5uhvLV9PGNRKAUhcWxi2XsjJ80ibVfe 3wgIULB9s6485wkrpUNp+gRwUD68i58us5qaKfn4UM+rT/Gr8MtcZwIoM1wPKgas bbkZGpM1ebpqb2z3l+pjN1mgZsoXiWTLQQIytovuisA1XIUHIBRV40FPi5GBLa6C j0+4voECgYEA4hY1woLsLw3+rTveUg2f6pwubBB96U0WcGugYGNajmvgD4hjl9m5 8KmJAFDVMOWEr7PF/0fpF5P+41gZfbEimGOY9jnTxtOEw8WOJXlKGRGl6Ofv7fXf p+C+HNM5UO+bslWc3vTFq3GJh7CFfAZTwPRNxl02wZqN8G8BJ8XWwTsCgYEAyVeG hkYVIzMmBU7aJdHfOdZL6i2DLJUsFZAGgNraiTkiKzKkg8BEgTnUoWs6ZDkFxdO1 Bo0/Sq3iGlxIHGtpRNCf8fq+0HQcnJCjpl2hr/uXP2RE9hEWu2rZvJVufGH4VAEr ifEZJEy5Z6WtgoK1swV5A4YsPL7OJTnpD8VjbVECgYBxOJYrls0Ys3V646Ruiwwu vZAx5gBoOYanPf7OxnKvKC7JGJBnl02azAwj8FcTaZ2NMAZT1XtRp3fZ+mCppW+h yR7tEACSbZLrR5/r/FWzQDdJ7/0juiILPG14mf72HUhngqBQt1vWg8FQBoKSnciL tMzOLhgh1HiIk86MUHM/yQKBgQC8EFwgSY/u3BTUem27S8iFPoyURUS0PPX7ghcA /uuHp20qCliuk8WpKvpYeE8HVFf3C6OYZhDLUZXTZ4UXvqCKXZA4tyzKito6x8OE Xwrq1UbWOHNNoHKqRsjwpGeaGOyakqk3ZJNGW8AGdzOVpz/O4vrA9u+VIehtzyTJ zWbssQKBgQCrZTLG1rsJB/ndAjooODaTnk7IwnAfJDrOdFEArGbwq8roBeaA6BGi yB02FRWIin5gaLZmHGfWOalKiCtFTZnaeuRFKoDOERxnCTt9X8kbT/rxX0/zKSGy ddv2LOrfvk5KXmzvFjVbXnTuVAPRU05LGAVR2WlbNji6/orlMCEfFg== -----END RSA PRIVATE KEY----- Event-RPC-1.10/t/ssl/server-noca.crt0000644000175000017500000000240513314245553016162 0ustar joernjoern-----BEGIN CERTIFICATE----- MIIDiDCCAnCgAwIBAgIJANuXHmz0h8eOMA0GCSqGSIb3DQEBCwUAMFkxCzAJBgNV BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX aWRnaXRzIFB0eSBMdGQxEjAQBgNVBAsMCWxvY2FsaG9zdDAeFw0xODA2MjUxOTUw NDFaFw00ODAxMTkxOTUwNDFaMFkxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21l LVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQxEjAQBgNV BAsMCWxvY2FsaG9zdDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBALHQ vJAzjqEp8RUhdEsxDt6h2+COM0VZoUlxlVZW99yB+Av5EPY6i1nsnzrP4p3wLi/g +4gOKs7W97HHUIbNdY6+FxGlfLPXw36yhJY3ne+fSDoRkJzDwxYsrVEpEldDvl2j roJCKwJNmhzZEkbjH9REYuZsOI0F3gADMtsVHc0BDmWkUwO5r4gDUjobgKX8qfcc /fH0p85pG4NcqtKk1feNmxb7OkvWIo01yP0FLjSMiFVQEyHmd6rlUOVFpPax+ZWo jGepjWz0CTiRzhoX3JI6F2Hkoqa2F0ymLaw7JSW4BECrr2hpIQdKiAaEp6ldFrmv /ujlCF+2/tQXBioKQqsCAwEAAaNTMFEwHQYDVR0OBBYEFBGTeLiYzG2DRVYOcI5n b0VDhck3MB8GA1UdIwQYMBaAFBGTeLiYzG2DRVYOcI5nb0VDhck3MA8GA1UdEwEB /wQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEBAAOyJhy3S8RDpxhW7ypJ+ceiFRcl F3dREws1cgRIxEEi6RJ25BwTTydgX+pT0fIoOTfJS4J7M3rSEz4AQpRBIUKytpKQ 2o9LOdEMh2h/9EpIr26gwwmuDaCj+aG2z+bsXUxRoHgvAuOHwY1HljItOpTOEAHt yw3MKsEZg0sMbVHFAhFwv6Y8btkDvignvteoEz8ooW7kjXMpjdmV+OYPm5UpQpww 2Ze7jv47WeHBvtTjCccVOObmponzUWiPTUTncqQ8ZhxjQ76Ld4JPMvq8kyQg0Qgv wInnPcPsYtgEdKhePeuRTRHkhkkBNd7FadjAYDN4sdZUzwUGZ2/lphS1xP8= -----END CERTIFICATE----- Event-RPC-1.10/t/ssl/server.crt0000644000175000017500000000222013314245553015237 0ustar joernjoern-----BEGIN CERTIFICATE----- MIIDMTCCAhkCCQC7Vm8H9FUV0DANBgkqhkiG9w0BAQsFADBcMQswCQYDVQQGEwJB VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 cyBQdHkgTHRkMRUwEwYDVQQLDAxFdmVudC1SUEMgQ0EwHhcNMTgwNjI1MTk1MDQx WhcNNDgwMTE5MTk1MDQxWjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1T dGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQD DAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCx0LyQ M46hKfEVIXRLMQ7eodvgjjNFWaFJcZVWVvfcgfgL+RD2OotZ7J86z+Kd8C4v4PuI DirO1vexx1CGzXWOvhcRpXyz18N+soSWN53vn0g6EZCcw8MWLK1RKRJXQ75do66C QisCTZoc2RJG4x/URGLmbDiNBd4AAzLbFR3NAQ5lpFMDua+IA1I6G4Cl/Kn3HP3x 9KfOaRuDXKrSpNX3jZsW+zpL1iKNNcj9BS40jIhVUBMh5neq5VDlRaT2sfmVqIxn qY1s9Ak4kc4aF9ySOhdh5KKmthdMpi2sOyUluARAq69oaSEHSogGhKepXRa5r/7o 5Qhftv7UFwYqCkKrAgMBAAEwDQYJKoZIhvcNAQELBQADggEBAGjtfC6XjVxJMpOq iZpcLoqSzr7/ab6mhCIEVNWkPxJZ3F+se8gRhd30arXqJR9q+0CNPUvrVVwuwxN5 rjZeYjYsQotxMEe3sflFOReIUih7qxUQJD3q4l67rzcwq5n5k1owZDeyBoR5fapE 6tAIk10WRzOkujZs9AxWu6CdOIees/lv+Ed83OFrSQgGdUlQYhmcBKUqHLFpNHbE ROk5tBB3rm6gFMTyHRDilozZIv3taehMxyPkjwfBqH7pEudyItNs1GgY1oIScoao b6lrR1k8LggUY3tP4KA3Es52//chZNtF7XVTQFDsN096ygJ69PeALmzC3wPkJzOn zIgFQWA= -----END CERTIFICATE----- Event-RPC-1.10/t/Event_RPC_Test.pm0000644000175000017500000000626312601723500015542 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event_RPC_Test; use Event_RPC_Test2; use strict; use utf8; sub get_data { shift->{data} } sub get_object2 { shift->{object2} } sub set_data { shift->{data} = $_[1] } sub set_object2 { shift->{object2} = $_[1] } sub new { my $class = shift; my %par = @_; my ($data) = $par{'data'}; my $self = bless { data => $data, object2 => Event_RPC_Test2->new("foo"), }, $class; return $self; } my $SINGLETON; sub singleton { my $class = shift; return $SINGLETON if $SINGLETON; return $SINGLETON = $class->new(data => "singleton"), } sub hello { my $self = shift; return "I hold this data: '".$self->get_data."'"; } sub quit { my $self = shift; my $rpc_server = Event::RPC::Server->instance; $rpc_server->get_loop->add_timer ( after => 1, cb => sub { $rpc_server->stop }, ); return "Server stops in one second"; } sub clone { my $self = shift; my $clone = (ref $self)->new ( data => $self->get_data ); return $clone; } sub multi { my $self = shift; my ($num) = @_; my (@list, %hash); while ($num) { push @list, $hash{$num} = (ref $self)->new ( data => $num ); --$num; } return (\@list, \%hash); } sub echo { my $self = shift; my (@params) = @_; return @params; } sub get_cid { my $self = shift; my $connection = Event::RPC::Server->instance->get_active_connection; my $cid = $connection->get_cid; return $cid; } sub get_object_cnt { my $self = shift; my $connection = Event::RPC::Server->instance->get_active_connection; my $client_oids = $connection->get_client_oids; my $cnt = keys %{$client_oids}; return $cnt; } sub get_undef_object { return undef; } sub new_object2 { my $class = shift; my ($data) = @_; return Event_RPC_Test2->new($data); } sub get_big_data_struct { my @records; for (0..100) { push @records, { a => 123, b => 456789, c => "ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n", d => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 20), e => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 20), f => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 50), g => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 50), x => $_, h => { a => 123, b => 456789, c => "ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n", d => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 20), e => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 20), f => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 50), g => ("ABCD ABCD ABCD ABCD ABCD ABCD ABCD ABCD\n" x 50), x => $_, }, }; } return \@records; } 1; Event-RPC-1.10/t/02.cnct.t0000644000175000017500000000222113314763015013751 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } plan tests => 5; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, ); # connect to server $client->connect; ok(1, "connected"); # create instance of test class over RPC my $object = Event_RPC_Test->new ( data => "Some test data. " x 6 ); ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); # disconnect client (this will also stop the server, # because we started it with the -S option) ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "stop server"); Event-RPC-1.10/t/07.maxpacket.t0000644000175000017500000000257013314763015015013 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } plan tests => 9; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, M => 1024, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, ); # connect to server $client->connect; ok(1, "connected"); ok($client->set_max_packet_size(1024) == 1024, "Client->set_max_packet_size"); ok($client->get_max_packet_size == 1024, "Client->get_max_packet_size"); my $data = "Some test data. " x 6; my $object = Event_RPC_Test->new ( data => $data ); ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); eval { $object->get_big_data_struct }; ok ($@ =~ /exceeds/, "packet too big: $@"); eval { $object->get_cid }; ok ($@ eq '', "packet small enough"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/04.cnct-auth-ssl-verifypeer.t0000644000175000017500000000313713314763015017676 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } eval { require IO::Socket::SSL }; if ( $@ ) { plan skip_all => "IO::Socket::SSL required"; } plan tests => 6; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; my $AUTH_USER = "foo"; my $AUTH_PASS = "bar"; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, a => "$AUTH_USER:$AUTH_PASS", s => 1, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, auth_user => $AUTH_USER, auth_pass => "wrong pass", ssl => 1, ssl_ca_file => "t/ssl/ca.crt", ); # try to connect with wrong password eval { $client->connect }; ok($@ ne '', "connection failed with wrong pw"); # now set correct password $client->set_auth_pass(Event::RPC->crypt($AUTH_USER,$AUTH_PASS)); # connect to server with correct password $client->connect; ok(1, "connected"); # create instance of test class over RPC my $object = Event_RPC_Test->new ( data => "Some test data. " x 6 ); ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/04.cnct-auth-ssl.t0000644000175000017500000000306413314763015015517 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } eval { require IO::Socket::SSL }; if ( $@ ) { plan skip_all => "IO::Socket::SSL required"; } plan tests => 6; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; my $AUTH_USER = "foo"; my $AUTH_PASS = "bar"; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, a => "$AUTH_USER:$AUTH_PASS", s => 1, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, auth_user => $AUTH_USER, auth_pass => "wrong pass", ssl => 1, ); # try to connect with wrong password eval { $client->connect }; ok($@ ne '', "connection failed with wrong pw"); # now set correct password $client->set_auth_pass(Event::RPC->crypt($AUTH_USER,$AUTH_PASS)); # connect to server with correct password $client->connect; ok(1, "connected"); # create instance of test class over RPC my $object = Event_RPC_Test->new ( data => "Some test data. " x 6 ); ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/01.use.t0000644000175000017500000000016012601723500013606 0ustar joernjoernuse strict; use utf8; use Test::More tests => 2; use_ok('Event::RPC::Server'); use_ok('Event::RPC::Client'); Event-RPC-1.10/t/04.cnct-auth-ssl-verifypeer-noca.t0000644000175000017500000000260713314763015020615 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } eval { require IO::Socket::SSL }; if ( $@ ) { plan skip_all => "IO::Socket::SSL required"; } plan tests => 4; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; my $AUTH_USER = "foo"; my $AUTH_PASS = "bar"; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging my $server_pid = Event_RPC_Test_Server->start_server ( p => $PORT, a => "$AUTH_USER:$AUTH_PASS", s => 1, sf => 't/ssl/server-noca.crt', S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, auth_user => $AUTH_USER, auth_pass => Event::RPC->crypt($AUTH_USER,$AUTH_PASS), ssl => 1, ssl_ca_file => "t/ssl/ca.crt", ); # connect to server: should fail due to non signed key eval { $client->connect }; ok($@, "ssl connection failed due to unsigned server key"); # shutdown server process ok(kill(2, $server_pid), "killing server process at PID $server_pid"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/08.msg_formats.t0000644000175000017500000001457513314763015015370 0ustar joernjoernuse strict; use utf8; use Test::More; use Event::RPC::Server; use Event::RPC::Message::Negotiate; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; # determine available message formats (including the insecure) my $formats = Event::RPC::Server->probe_message_formats( Event::RPC::Message::Negotiate->message_format_order, 1 ); my $modules_by_name = Event::RPC::Message::Negotiate->known_message_formats; my $tests = 1 + @{$formats} * 14 + 9 * 3; plan tests => $tests; # load client class use_ok('Event::RPC::Client'); foreach my $format ( @{$formats} ) { # start server in background, without logging my $server_pid = Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, f => [ $format ] ); ok($server_pid, "Started server at $server_pid with format '$format'"); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, ); # connect to server $client->connect; ok(1, "connected"); # check message format ok($client->get_message_format eq $modules_by_name->{$format}, "$format format chosen"); # create instance of test class over RPC my $data = "Some test data with utf8: 你好世界. " x 6; my $object = Event_RPC_Test->new ( data => $data ); # check object ok($object->isa("Event_RPC_Test"), "object is Event_RPC_Test"); # check data ok($object->get_data eq $data, "object data matches"); # set binary data my $bin_data = join("", map { chr($_) } 0..255); $bin_data = $bin_data x 100; ok($object->set_data($bin_data) eq $bin_data, "object bin data set"); ok($object->get_data eq $bin_data, "object bin data get"); # get another object from this object my $object2 = $object->get_object2; ok($object2->isa("Event_RPC_Test2"), "object is Event_RPC_Test2"); # check data of object2 ok($object2->get_data eq 'foo', "object data is 'foo'"); # create another object from this object $object2 = $object->new_object2($$); ok($object2->isa("Event_RPC_Test2"), "object is Event_RPC_Test2"); # check data of object2 ok($object2->get_data == $$, "object data is $$"); $object2->set_data($data); # check if copying the complete object hash works my $ref = $object2->get_object_copy; ok($ref->{data} eq $data, "object copy data matches"); if ( $ENV{EVENT_RPC_BENCHMARK} ) { require Benchmark; my @objects; my @payload = map { $_ => ("Huge payload $_" x 100) } 1..100; diag "Performing benchmark for '$format'"; my $cnt = 20; my $t = Benchmark::timeit($cnt, sub { for ( 1..1000 ) { push @objects, $object->new_object2(\@payload); } $_->set_data(42) for @objects; @objects = (); }); diag "$cnt loops of '$format' took ".Benchmark::timestr($t); } # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); } SKIP: { my ($other_format) = grep { $_ ne "STOR" } @{$formats}; my ($has_storable) = grep { $_ eq "STOR" } @{$formats}; plan skip "Negotations tests skipped due to missing formats", 9*3 unless $other_format and $has_storable; foreach my $client_style (qw/ old insecure secure /) { foreach my $server_style (qw/ old insecure secure /) { if ( $client_style eq 'old' ) { $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Storable"; } else { $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Negotiate"; } if ( $server_style eq 'old' ) { $Event::RPC::Server::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Storable"; } else { $Event::RPC::Server::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Negotiate"; } my $client_insecure_ok = $client_style eq 'secure' ? 0 : 1; my $server_insecure_ok = $server_style eq 'secure' ? 0 : 1; my $server_formats = $server_style eq 'old' ? ["STOR"] : $server_style eq 'insecure' ? ["STOR"] : [ $other_format ]; # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, f => $server_formats, i => $server_insecure_ok, l => 0, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, insecure_msg_fmt_ok => $client_insecure_ok, ); # connect to server eval { $client->connect }; if ( $server_style eq 'secure' and $client_style eq 'old' or $client_style eq 'secure' and $server_style eq 'old') { ok($@, "connection failed, server($server_style) | client($client_style) | si=$server_insecure_ok ci=$client_insecure_ok"); } else { ok(!$@, "connection succeeded, server($server_style) | client($client_style) | si=$server_insecure_ok ci=$client_insecure_ok"); } if ( $client->get_connected ) { ok( ($server_style."|".$client_style =~ /\bsecure\b/ && $client->get_message_format !~ /Storable/) || ($server_style."|".$client_style !~ /\bsecure\b/ && $client->get_message_format =~ /Storable/), "Correct message format chosen" ); $client->disconnect; } else { ok(1, "No security check on connection failure"); } # wait on server to quit wait; ok (1, "server stopped"); } } } Event-RPC-1.10/t/Event_RPC_Test2.pm0000644000175000017500000000050012601723500015610 0ustar joernjoernpackage Event_RPC_Test2; use strict; use utf8; sub get_data { shift->{data} } sub set_data { shift->{data} = $_[1] } sub new { my $class = shift; my ($data) = @_; return bless { data => $data, }, $class; } sub get_object_copy { my $self = shift; return $self; } 1; Event-RPC-1.10/t/Event_RPC_Test_Server.pm0000644000175000017500000001247312601723500017070 0ustar joernjoernpackage Event_RPC_Test_Server; use strict; use utf8; use lib qw(t); use Fcntl qw( :flock ); sub start_server { my $class = shift; my %opts = @_; #-- fork my $server_pid = fork(); die "can't fork" unless defined $server_pid; #-- Client? if ( $server_pid ) { #-- client tries to make a log connection to #-- verify that the server is up and running #-- (20 times with a usleep of 0.25, so the #-- overall timeout is 5 seconds) for ( 1..20 ) { eval { Event::RPC::Client->log_connect ( server => "localhost", port => $opts{p}+1, ); }; #-- return to client code if connect succeeded return $server_pid if !$@; #-- bail out if the limit is reached if ( $_ == 20 ) { die "Couldn't start server: $@"; } #-- wait a quarter second... select(undef, undef, undef, 0.25); } #-- Client is finished here return $server_pid; } #-- We're in the server require Event::RPC::Server; require Event::RPC::Logger; require Event_RPC_Test; require Event_RPC_Test2; #-- This code is mainly copied from the server.pl #-- example and works with a command line style #-- %opts hash my %ssl_args; if ( $opts{s} ) { %ssl_args = ( ssl => 1, ssl_key_file => 't/ssl/server.key', ssl_cert_file => ($opts{sf}||'t/ssl/server.crt'), ssl_passwd_cb => sub { 'eventrpc' }, ); if ( not -f 't/ssl/server.key' ) { print "please execute from toplevel directory\n"; } } my %auth_args; if ( $opts{a} ) { my ($user, $pass) = split(":", $opts{a}); $pass = Event::RPC->crypt($user, $pass); %auth_args = ( auth_required => 1, auth_passwd_href => { $user => $pass }, ); } #-- Create a logger object my $logger = $opts{l} ? Event::RPC::Logger->new ( min_level => $opts{l}, fh_lref => [ \*STDOUT ], ) : undef; #-- Create a loop object my $loop; my $loop_module = $opts{L}; if ( $loop_module ) { eval "use $loop_module"; die $@ if $@; $loop = $loop_module->new(); } my $port = $opts{p} || 5555; my $disconnect_cnt = $opts{S}; #-- Create a Server instance and declare the #-- exported interface my $server; $server = Event::RPC::Server->new ( name => "test daemon", port => $port, loop => $loop, logger => $logger, start_log_listener => 1, load_modules => 0, message_formats => $opts{f}, insecure_msg_fmt_ok => $opts{i}, %auth_args, %ssl_args, classes => { 'Event_RPC_Test' => { new => '_constructor', singleton => '_singleton', set_data => 1, get_data => 1, hello => 1, quit => 1, clone => '_object', multi => '_object', get_object2 => '_object', new_object2 => '_object', echo => 1, get_cid => 1, get_object_cnt => 1, get_undef_object => '_object', get_big_data_struct => 1, async_call_1 => 'object:async:reeintrant' }, 'Event_RPC_Test2' => { new => '_constructor', set_data => 1, get_data => 1, hello => 1, quit => 1, clone => '_object', multi => '_object', get_object2 => '_object', new_object2 => '_object', echo => 1, get_cid => 1, get_object_cnt => 1, get_undef_object => '_object', get_big_data_struct => 1, async_call_1 => 'object:async:reeintrant' }, 'Event_RPC_Test2' => { new => '_constructor', set_data => 1, get_data => 1, get_object_copy => 1, }, }, connection_hook => sub { my ($conn, $event) = @_; return if $event eq 'connect'; --$disconnect_cnt; $server->stop if $disconnect_cnt <= 0 && $server->get_clients_connected == 0; 1; }, ); $server->set_max_packet_size($opts{M}) if $opts{M}; #-- Start the server resp. the Event loop. $server->start; #-- Exit the program exit; } sub port { my $file = "port.txt"; open (my $fh, "+>>", $file) or die "Can't open '$file': $!"; flock($fh, LOCK_EX) or die "Cannot lock $file: $!"; seek $fh, 0, 0; my $port = <$fh> || 27808; chomp $port; truncate $fh, 0; $port += 2; $port = 27810 if $port > 65000; print $fh "$port\n"; close $fh; return $port; } 1; Event-RPC-1.10/t/04.cnct-auth-ssl-verifypeer-wrongca.t0000644000175000017500000000265513314763015021340 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } eval { require IO::Socket::SSL }; if ( $@ ) { plan skip_all => "IO::Socket::SSL required"; } plan tests => 5; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; my $AUTH_USER = "foo"; my $AUTH_PASS = "bar"; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, a => "$AUTH_USER:$AUTH_PASS", s => 1, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, auth_user => $AUTH_USER, auth_pass => Event::RPC->crypt($AUTH_USER,$AUTH_PASS), ssl => 1, ssl_ca_file => "t/ssl/ca-wrong.crt", ); # connect to server: should fail due to wrong ca eval { $client->connect }; ok($@, "ssl connection failed with wrong ca"); # now correct ca to shut down server $client->set_ssl_ca_file("t/ssl/ca.crt"); ok($client->connect, "connect with correct ca"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/05.func.t0000644000175000017500000000521713314763015013770 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } plan tests => 18; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, ); # count created objects my $object_cnt = 0; # connect to server $client->connect; ok(1, "connected"); # create instance of test class over RPC my $data = "Some test data. " x 6; my $object = Event_RPC_Test->new ( data => $data ); ++$object_cnt; ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); # test data ok ($object->get_data eq $data, "data member ok"); # set data, some utf8 ok ($object->set_data("你好世界") eq "你好世界", "set data utf8"); # check set data, some utf8 ok ($object->get_data eq "你好世界", "get data utf8"); # set data ok ($object->set_data("foo") eq "foo", "set data"); # check set data ok ($object->get_data eq "foo", "get data"); # object transfer my $clone; ++$object_cnt; ok ( $clone = $object->clone, "object transfer"); # check clone $clone->set_data("bar"); ok ( $clone->get_data eq 'bar' && $object->get_data eq 'foo', "clone"); # transfer a list of objects my ($lref, $href) = $object->multi(10); $object_cnt += 10; ok ( @$lref == 10 && $lref->[5]->get_data == 5, "multi object list"); ok ( keys(%$href) == 10 && $href->{4}->get_data == 4, "multi object hash"); # complex parameter transfer my @params = ( "scalar", { 1 => "hash" }, [ "a", "list" ], ); my @result = $object->echo(@params); ok ( @result == 3 && $result[0] eq 'scalar' && ref $result[1] eq 'HASH' && $result[1]->{1} eq 'hash' && ref $result[2] eq 'ARRAY' && $result[2]->[1] eq 'list' , "complex parameter transfer" ); # get connection cid ok ($object->get_cid == 1, "access connection object"); # get client object cnt via connection ok ($object->get_object_cnt == $object_cnt, "client object cnt via connection"); # check undef object returner ok (!defined $object->get_undef_object, "get undef from an object returner"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/03.cnct-auth.t0000644000175000017500000000277713314763015014731 0ustar joernjoernuse strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } plan tests => 6; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; my $AUTH_USER = "foo"; my $AUTH_PASS = "bar"; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, a => "$AUTH_USER:$AUTH_PASS", S => 2, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, auth_user => $AUTH_USER, auth_pass => "wrong", ); # try to connect with wrong password eval { $client->connect }; ok($@ ne '', "connection failed with wrong pw"); # now set correct password $client->set_auth_pass(Event::RPC->crypt($AUTH_USER,$AUTH_PASS)); # connect to server with correct password $client->connect; ok(1, "connected"); # create instance of test class over RPC my $object = Event_RPC_Test->new ( data => "Some test data. " x 6 ); ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC"); # disconnect client (this will also stop the server, # because we started it with the -D option) ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/t/06.object2.t0000644000175000017500000000331113314763015014357 0ustar joernjoern#!/usr/bin/perl use strict; use utf8; use Test::More; my $depend_modules = 0; eval { require EV }; eval { require AnyEvent } && ++$depend_modules; eval { require Event } && ++$depend_modules; eval { require Glib } && ++$depend_modules; if ( not $depend_modules ) { plan skip_all => "Neither AnyEvent, Event nor Glib installed"; } plan tests => 10; require "./t/Event_RPC_Test_Server.pm"; my $PORT = Event_RPC_Test_Server->port; # load client class use_ok('Event::RPC::Client'); # start server in background, without logging Event_RPC_Test_Server->start_server ( p => $PORT, S => 1, L => $ENV{EVENT_RPC_LOOP}, ); # create client instance my $client = Event::RPC::Client->new ( host => "localhost", port => $PORT, ); # connect to server $client->connect; ok(1, "connected"); # create instance of test class over RPC my $data = "Some test data. " x 6; my $object = Event_RPC_Test->new ( data => $data ); # check object ok($object->isa("Event_RPC_Test"), "object is Event_RPC_Test"); # get another object from this object my $object2 = $object->get_object2; ok($object2->isa("Event_RPC_Test2"), "object is Event_RPC_Test2"); # check data of object2 ok($object2->get_data eq 'foo', "object data is 'foo'"); # create another object from this object $object2 = $object->new_object2($$); ok($object2->isa("Event_RPC_Test2"), "object is Event_RPC_Test2"); # check data of object2 ok($object2->get_data == $$, "object data is $$"); # check if copying the complete object hash works my $ref = $object2->get_object_copy; ok($ref->{data} == $$, "object copy data is $$"); # disconnect client ok ($client->disconnect, "client disconnected"); # wait on server to quit wait; ok (1, "server stopped"); Event-RPC-1.10/Makefile.PL0000644000175000017500000000557012601723500014127 0ustar joernjoern# $Id: Makefile.PL,v 1.2 2005/04/15 21:11:49 joern Exp $ use strict; use ExtUtils::MakeMaker; my $loop_modules = 0; my $has_event = 0; my $has_glib = 0; my $has_anyevent = 0; my $format_modules = 0; my $has_sereal = 0; my $has_cbor_xs = 0; my $has_json_xs = 0; my $has_storable = 0; eval { require Event; $has_event = 1 } && ++$loop_modules; eval { require Glib; $has_glib = 1 } && ++$loop_modules; eval { require AnyEvent; $has_anyevent = 1 } && ++$loop_modules; eval { require Sereal; $has_sereal = 1 } && ++$format_modules; eval { require CBOR::XS; $has_cbor_xs = 1 } && ++$format_modules; eval { require JSON::XS; $has_json_xs = 1 } && ++$format_modules; eval { require Storable; $has_storable = 1 } && ++$format_modules; if ( !$loop_modules ) { print "\n"; print "*****************************************************************\n"; print "WARNING: You need Event, Glib or AnyEvent for Event::RPC to work!\n"; print "*****************************************************************\n"; print "\n"; } if ( !$format_modules ) { print "\n"; print "*****************************************************************\n"; print "WARNING: You need Sereal, CBOR::XS, JSON::XS or Storable module\n"; print "*****************************************************************\n"; print "\n"; } my $has_ssl; eval { require IO::Socket::SSL; $has_ssl = 1 } || do { print "\n"; print "NOTE: Event::RPC is capable of SSL encrypted connections,\n"; print " but your Perl is missing the IO::Socket::SSL module.\n"; print " Event::RPC works perfectly without the module, but you\n"; print " can't use SSL connections until IO::Socket::SSL is\n"; print " installed.\n"; print "\n"; }; #-- Add found modules to PREREQ_PM, so CPAN Testers add #-- version numbers of these modules to the reports, which #-- are very important in case of failing tests. my @add_prereq; push @add_prereq, 'AnyEvent', 0 if not $loop_modules; push @add_prereq, 'Event', 0 if $has_event; push @add_prereq, 'Glib', 0 if $has_glib; push @add_prereq, "Sereal", 3.0 if $has_sereal or not $format_modules; push @add_prereq, "CBOR::XS", 0 if $has_cbor_xs; push @add_prereq, "JSON::XS", 3.0 if $has_json_xs; push @add_prereq, "Storable", 0 if $has_storable; push @add_prereq, 'IO::Socket::SSL', 0 if $has_ssl; push @add_prereq, 'Net::SSLeay', 0 if $has_ssl; WriteMakefile( 'NAME' => 'Event::RPC', 'VERSION_FROM' => 'lib/Event/RPC.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'Storable' => 0, 'IO::Socket::INET' => 0, @add_prereq, }, 'dist' => { COMPRESS => "gzip", SUFFIX => "gz", PREOP => q[pod2text lib/Event/RPC.pm > README], POSTOP => q[mkdir -p dist && mv Event-RPC-*tar.gz dist/], }, ); Event-RPC-1.10/MANIFEST0000644000175000017500000000227613314763036013320 0ustar joernjoernChanges MANIFEST Makefile.PL META.yml README lib/Event/RPC.pm lib/Event/RPC/AuthPasswdHash.pm lib/Event/RPC/Client.pm lib/Event/RPC/Logger.pm lib/Event/RPC/Loop.pm lib/Event/RPC/Loop/AnyEvent.pm lib/Event/RPC/Loop/Event.pm lib/Event/RPC/Loop/Glib.pm lib/Event/RPC/Server.pm lib/Event/RPC/Connection.pm lib/Event/RPC/LogConnection.pm lib/Event/RPC/Message.pm lib/Event/RPC/Message/Negotiate.pm lib/Event/RPC/Message/Storable.pm lib/Event/RPC/Message/JSON.pm lib/Event/RPC/Message/CBOR.pm lib/Event/RPC/Message/Sereal.pm lib/Event/RPC/Message/SerialiserBase.pm t/01.use.t t/02.cnct.t t/03.cnct-auth.t t/04.cnct-auth-ssl.t t/04.cnct-auth-ssl-verifypeer-noca.t t/04.cnct-auth-ssl-verifypeer.t t/04.cnct-auth-ssl-verifypeer-wrongca.t t/05.func.t t/06.object2.t t/07.maxpacket.t t/08.msg_formats.t t/Event_RPC_Test.pm t/Event_RPC_Test2.pm t/Event_RPC_Test_Server.pm t/ssl/ca.crt t/ssl/ca.key t/ssl/ca-wrong.crt t/ssl/ca-wrong.key t/ssl/server.crt t/ssl/server.csr t/ssl/server.key t/ssl/server-noca.crt examples/server.pl examples/client.pl examples/Test_class.pm examples/ssl/server.key examples/ssl/server.csr examples/ssl/server.crt META.json Module JSON meta-data (added by MakeMaker) Event-RPC-1.10/META.json0000664000175000017500000000216213314763036013604 0ustar joernjoern{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Event-RPC", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Event" : "0", "Glib" : "0", "IO::Socket::INET" : "0", "IO::Socket::SSL" : "0", "JSON::XS" : "3", "Net::SSLeay" : "0", "Sereal" : "3", "Storable" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "version" : "1.10", "x_serialization_backend" : "JSON::PP version 2.27300" } Event-RPC-1.10/README0000644000175000017500000001437213314763036013047 0ustar joernjoernNAME Event::RPC - Event based transparent Client/Server RPC framework SYNOPSIS #-- Server Code use Event::RPC::Server; use My::TestModule; my $server = Event::RPC::Server->new ( port => 5555, classes => { "My::TestModule" => { ... } }, ); $server->start; ---------------------------------------------------------- #-- Client Code use Event::RPC::Client; my $client = Event::RPC::Client->new ( server => "localhost", port => 5555, ); $client->connect; #-- Call methods of My::TestModule on the server my $obj = My::TestModule->new ( foo => "bar" ); my $foo = $obj->get_foo; ABSTRACT Event::RPC supports you in developing Event based networking client/server applications with transparent object/method access from the client to the server. Network communication is optionally encrypted using IO::Socket::SSL. Several event loop managers are supported due to an extensible API. Currently Event, Glib and AnyEvent are implemented. The latter lets you use nearly every event loop implementation available for Perl. AnyEvent was invented after Event::RPC was created and thus Event::RPC started using it's own abstraction model. DESCRIPTION Event::RPC consists of a server and a client library. The server exports a list of classes and methods, which are allowed to be called over the network. More specific it acts as a proxy for objects created on the server side (on demand of the connected clients) which handles client side methods calls with transport of method arguments and return values. The object proxy handles refcounting and destruction of objects created by clients properly. Objects as method parameters and return values are handled as well (although with some limitations, see below). For the client the whole thing is totally transparent - once connected to the server it doesn't know whether it calls methods on local or remote objects. Also the methods on the server newer know whether they are called locally or from a connected client. Your application logic is not affected by Event::RPC at all, at least if it has a rudimentary clean OO design. For details on implementing servers and clients please refer to the man pages of Event::RPC::Server and Event::RPC::Client. REQUIREMENTS Event::RPC needs either one of the following modules on the server (they're not necessary on the client): Event Glib AnyEvent They're needed for event handling resp. mainloop implementation. If you like to use SSL encryption you need to install IO::Socket::SSL Event::RPC needs minimum one of the following modules for data serialisation: Sereal (::Decoder and ::Encoder) CBOR::XS JSON::XS Storable Server and client negotiate automatically which serialiser to use to achieve maximum compatibility. Some words about the Storable module: it's known to be insecure, so Event::RPC uses it as the last option. You can even prevent Event::RPC from using it at all (even when it's installed, which is the case for nearly every Perl installation) - check manpages of Event::Server and Event::Client about the details. In case you use Storable take care that both client and server use exactly the same version of the Storable module! Otherwise Event::RPC client/server communication will fail badly. INSTALLATION You get the latest installation tarballs and online documentation at this location: http://www.exit1.org/Event-RPC/ If your system meets the requirements mentioned above, installation is just: perl Makefile.PL make test make install To test a specific Event loop implementation, export the variable EVENT_RPC_LOOP: export EVENT_RPC_LOOP=Event::RPC::Loop::Glib make test Otherwise Event::RPC will fallback to the most appropriate module installed on your system. EXAMPLES The tarball includes an examples/ directory which contains two programs: server.pl client.pl Just execute them with --help to get the usage. They do some very simple communication but are good to test your setup, in particular in a mixed environment. LIMITATIONS Although the classes and objects on the server are accessed transparently by the client there are some limitations should be aware of. With a clean object oriented design these should be no problem in real applications: Direct object data manipulation is forbidden All objects reside on the server and they keep there! The client just has specially wrapped proxy objects, which trigger the necessary magic to access the object's methods on the server. Complete objects are never transferred from the server to the client, so something like this does not work: $object->{data} = "changed data"; (assuming $object is a hash ref on the server). Only method calls are transferred to the server, so even for "simple" data manipulation a method call is necessary: $object->set_data ("changed data"); As well for reading an object attribute. Accessing a hash key will fail: my $data = $object->{data}; Instead call a method which returns the 'data' member: my $data = $object->get_data; Methods may exchange objects, but not in a too complex structure Event::RPC handles methods which return objects. The only requirement is that they are declared as a Object returner on the server (refer to Event::RPC::Server for details), but not if the object is hidden inside a deep complex data structure. An array or hash ref of objects is Ok, but not more. This would require to much expensive runtime data inspection. Object receiving parameters are more restrictive, since even hiding them inside one array or hash ref is not allowed. They must be passed as a direkt argument of the method subroutine. AUTHORS Jörn Reder COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Event-RPC-1.10/examples/0000755000175000017500000000000013314763036013776 5ustar joernjoernEvent-RPC-1.10/examples/ssl/0000755000175000017500000000000013314763036014577 5ustar joernjoernEvent-RPC-1.10/examples/ssl/server.csr0000644000175000017500000000131010230026674016603 0ustar joernjoern-----BEGIN CERTIFICATE REQUEST----- MIIB1jCCAT8CAQAwgZUxCzAJBgNVBAYTAkRFMREwDwYDVQQIEwhJcmdlbmR3bzEO MAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9yZzEdMBsGA1UECxMUU29m dHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4gUmVkZXIxGzAZBgkqhkiG 9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA pKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRhCCNfUufY8Jslmn/4hZI4 wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35uWoMw343kZA4G6eLqjWV y8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8CAwEAAaAAMA0GCSqGSIb3 DQEBBAUAA4GBAJmfq2IqvN+m9IIRzNTHBjEaOeYIEFVKcqWIiui/hvw8M7Yi0op2 ifOjRKSfYTsgNAst1Ilwg6wgblSngg6f9GpGtWAYr1xQpoWS8PDaqjx1sLE40qi2 aNrCtrSCLxzLh9o0qeUydcrjvIK6sWe6lGRntjNoj2VCqlBm0EFQ7vNF -----END CERTIFICATE REQUEST----- Event-RPC-1.10/examples/ssl/server.key0000644000175000017500000000170310230026674016612 0ustar joernjoern-----BEGIN RSA PRIVATE KEY----- Proc-Type: 4,ENCRYPTED DEK-Info: DES-EDE3-CBC,CEB8A2E7F9C59066 mUDYr4fgc2lba+qobTYxcq/8ZpRS1cdoiCe1QQeSQ2Bywrsgx8H40hqkBsKOYBPa ZFC+EEQTfhGOswTD5YsgqfTyWc7w0qlXDlPCVgV28r96gKzpP6oEDoclriWsToDF ZOsANyGcdl4D4VyY+oOf9crUFqIC4C/IfUJ++pZCUlGy8k/J0qHl/kCEP1bPg92q tKrG/gcDtrqnVHYB22MruAXHSAo4JOO7A6ZmrRGH4XY5SKGZPF/T7kwLLzEXbPq2 MDrcPg3xWcCvODswrptdmK73PyF5oWkA7NXAofecu51jW1Y9G48p1lQi0mAgP3qP LDxCFQUU52G9UAxmfd8pZBSntRIsaIQV+6ffM8TemObgf1VkisCGDUCnEgvj2zDN AaieLhR4MKIQuYZSTLfCI5mKZK0vCFP5t19wK6Clt7p9bq1aUu8HkqEZ5yrNmf04 acKvUkDbVCPL1pkAsyNAEQ4Zs3f3VxkuRrtf7gqzEEFK1TQoH7JmaALqGftgkPYJ eEYX8Om/Gr8NxTftSNbnoaFUyeoBOQ1iZY2g4qqE0rZlc7lfXiXAV3ajtgPcreZa +uU4g8DF7zfQ7F8FK7w2ryLJFdlgk7SzEjv1VzCQTQ2MjBOCs0gJ3SPF6wx6lfyH 9HqYRu2OwPJlaTzVrdhwKesROuBr1+rJym18uvzObSgkbTrFQuuYcR0dNbs+AuqQ dkhOC6bzpOdZNWVnVQ7klbsj8iUSMs4QnSI0+DpSls5VOMJiAXqPCAy4YJ0GAcGv EDF12ONiToyGb0Jolo+WOXyDebHR19TxokTcC5Ri7305mtRAP7g1fQ== -----END RSA PRIVATE KEY----- Event-RPC-1.10/examples/ssl/server.crt0000644000175000017500000000172110230026674016612 0ustar joernjoern-----BEGIN CERTIFICATE----- MIICozCCAgwCCQC7s/EOvPkeSTANBgkqhkiG9w0BAQQFADCBlTELMAkGA1UEBhMC REUxETAPBgNVBAgTCElyZ2VuZHdvMQ4wDAYDVQQHEwVLb2VsbjESMBAGA1UEChMJ ZXhpdDEub3JnMR0wGwYDVQQLExRTb2Z0d2FyZSBEZXZlbG9wbWVudDETMBEGA1UE AxQKSvZybiBSZWRlcjEbMBkGCSqGSIb3DQEJARYMam9lcm5AenluLmRlMB4XDTA1 MDMxMzE3NDg1NloXDTE1MDEyMDE3NDg1NlowgZUxCzAJBgNVBAYTAkRFMREwDwYD VQQIEwhJcmdlbmR3bzEOMAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9y ZzEdMBsGA1UECxMUU29mdHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4g UmVkZXIxGzAZBgkqhkiG9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0B AQEFAAOBjQAwgYkCgYEApKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRh CCNfUufY8Jslmn/4hZI4wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35 uWoMw343kZA4G6eLqjWVy8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8C AwEAATANBgkqhkiG9w0BAQQFAAOBgQAaahVlE9jXt0GO+Zk9ZDUmyiLQ31lhRbvr /fFqLYB3WS0xGnKKaj3IQFREkke7an4rhUaZLGstAhF3bXcN//t9bgZKQfnRPsM2 bQHEVWAtwjebv0Rn0uR53gZBxoCHZyGwCL0Tj0Gvynpou4Y8UDGnfc1E/r+HOTCO yvVrQL359w== -----END CERTIFICATE----- Event-RPC-1.10/examples/server.pl0000644000175000017500000000635412601723500015637 0ustar joernjoern#!/usr/bin/perl -w #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- use strict; use strict; use Event::RPC::Server; use Event::RPC::Logger; use Getopt::Std; my $USAGE = <<__EOU; Usage: server.pl [-l log-level] [-s] [-a user:pass] [-L loop-module] Description: Event::RPC server demonstration program. Execute this from the distribution's base or examples/ directory. Then execute examples/client.pl on another console. Options: -l log-level Logging level. Default: 4 -s Use SSL encryption -a user:pass Require authorization -h host Bind to this host interface. Default: localhost -L loop-module Event loop module to use. Default: Event::RPC::Loop::Event __EOU sub HELP_MESSAGE { my ($fh) = @_; $fh ||= \*STDOUT; print $fh $USAGE; exit; } main: { my %opts; my $opts_ok = getopts('h:L:l:a:s',\%opts); HELP_MESSAGE() unless $opts_ok; my %ssl_args; if ( $opts{s} ) { %ssl_args = ( ssl => 1, ssl_key_file => 'ssl/server.key', ssl_cert_file => 'ssl/server.crt', ssl_passwd_cb => sub { 'eventrpc' }, ); if ( not -f 'ssl/server.key' ) { chdir ("examples"); if ( not -f 'ssl/server.key' ) { print "please execute from toplevel or examples/ directory\n"; exit 1; } } } my %auth_args; if ( $opts{a} ) { my ($user, $pass) = split(":", $opts{a}); $pass = Event::RPC->crypt($user, $pass); %auth_args = ( auth_required => 1, auth_passwd_href => { $user => $pass }, ); } #-- Create a logger object my $logger = Event::RPC::Logger->new ( min_level => ($opts{l}||4), fh_lref => [ \*STDOUT ], ); #-- Create a loop object my $loop; my $loop_module = $opts{L}; if ( $loop_module ) { eval "use $loop_module"; die $@ if $@; $loop = $loop_module->new(); } #-- Host parameter my $host = $opts{h} || "localhost"; #-- Create a Server instance and declare the #-- exported interface my $server = Event::RPC::Server->new ( name => "test daemon", host => $host, port => 5555, logger => $logger, loop => $loop, start_log_listener => 1, auto_reload_modules => 1, message_formats => [qw/ SERL CBOR JSON STOR /], %auth_args, %ssl_args, classes => { 'Test_class' => { new => '_constructor', set_data => 1, get_data => 1, hello => 1, quit => 1, }, }, ); #-- Start the server resp. the Event loop. $server->start; } Event-RPC-1.10/examples/Test_class.pm0000644000175000017500000000176312601723500016435 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Test_class; use strict; sub get_data { shift->{data} } sub set_data { shift->{data} = $_[1] } sub new { my $class = shift; my %par = @_; my ($data) = $par{'data'}; my $self = bless { data => $data, }, $class; return $self; } sub hello { my $self = shift; return "Hello again. My data is: '".$self->get_data."' and event model is: $AnyEvent::MODEL"; } sub quit { my $self = shift; my $rpc_server = Event::RPC::Server->instance; $rpc_server->get_loop->add_timer ( after => 3, cb => sub { $rpc_server->stop }, ); return "Server stops in 3 seconds"; } 1; Event-RPC-1.10/examples/client.pl0000644000175000017500000000563012601723500015603 0ustar joernjoern#!/usr/bin/perl -w #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- use strict; use Event::RPC::Client; use Getopt::Std; my $USAGE = <<__EOU; Usage: client.pl [-s] [-a user:pass] Description: Event::RPC client demonstration program. Execute this from the distribution's base or examples/ directory after starting the correspondent examples/server.pl program. Options: -s Use SSL encryption -a user:pass Pass this authorization data to the server -h host Server hostname. Default: localhost __EOU sub HELP_MESSAGE { my ($fh) = @_; $fh ||= \*STDOUT; print $fh $USAGE; exit; } main: { my %opts; my $opts_ok = getopts('h:l:a:s',\%opts); HELP_MESSAGE() unless $opts_ok; my $ssl = $opts{s} || 0; my %auth_args; if ( $opts{a} ) { my ($user, $pass) = split(":", $opts{a}); $pass = Event::RPC->crypt($user,$pass); %auth_args = ( auth_user => $user, auth_pass => $pass, ); } #-- Host parameter my $host = $opts{h} || 'localhost'; #-- This connects to the server, requests the exported #-- interfaces and establishes correspondent proxy methods #-- in the correspondent packages. my $client; $client = Event::RPC::Client->new ( host => $host, port => 5555, ssl => $ssl, %auth_args, error_cb => sub { my ($client, $error) = @_; print "An RPC error occured!\n> $error"; print "Disconnect and exit.\n"; $client->disconnect if $client; exit; }, classes => [ "Test_class" ], ); $client->connect; print "\nConnected to localhost:5555\n\n"; print "Server version: ".$client->get_server_version,"\n"; print "Server protocol: ".$client->get_server_protocol,"\n"; print "Message format: ".eval { $client->get_message_format },"\n"; print "\n"; #-- So the call to Event::RPC::Test->new is handled transparently #-- by Event::RPC::Client print "** Create object on server\n"; my $object = Test_class->new ( data => "Initial data", ); print "=> Object created with data: '".$object->get_data."'\n\n"; #-- and methods calls as well... print "** Say hello to server.\n"; print "=> Server returned: >>".$object->hello,"<<\n"; print "\n** Update object data.\n"; $object->set_data ("Yes, updating works"); print "=> Retrieve data from server: '".$object->get_data."'\n"; print "\n** Disconnecting\n\n"; $client->disconnect; } Event-RPC-1.10/META.yml0000664000175000017500000000120513314763036013431 0ustar joernjoern--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Event-RPC no_index: directory: - t - inc requires: Event: '0' Glib: '0' IO::Socket::INET: '0' IO::Socket::SSL: '0' JSON::XS: '3' Net::SSLeay: '0' Sereal: '3' Storable: '0' Test::More: '0' version: '1.10' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Event-RPC-1.10/lib/0000755000175000017500000000000013314763036012726 5ustar joernjoernEvent-RPC-1.10/lib/Event/0000755000175000017500000000000013314763036014007 5ustar joernjoernEvent-RPC-1.10/lib/Event/RPC.pm0000644000175000017500000001412713314763015014773 0ustar joernjoernpackage Event::RPC; $VERSION = "1.10"; $PROTOCOL = "1.00"; use strict; use utf8; sub crypt { my $class = shift; my ($user, $pass) = @_; return crypt($pass, $user); } __END__ =encoding utf8 =head1 NAME Event::RPC - Event based transparent Client/Server RPC framework =head1 SYNOPSIS #-- Server Code use Event::RPC::Server; use My::TestModule; my $server = Event::RPC::Server->new ( port => 5555, classes => { "My::TestModule" => { ... } }, ); $server->start; ---------------------------------------------------------- #-- Client Code use Event::RPC::Client; my $client = Event::RPC::Client->new ( server => "localhost", port => 5555, ); $client->connect; #-- Call methods of My::TestModule on the server my $obj = My::TestModule->new ( foo => "bar" ); my $foo = $obj->get_foo; =head1 ABSTRACT Event::RPC supports you in developing Event based networking client/server applications with transparent object/method access from the client to the server. Network communication is optionally encrypted using IO::Socket::SSL. Several event loop managers are supported due to an extensible API. Currently Event, Glib and AnyEvent are implemented. The latter lets you use nearly every event loop implementation available for Perl. AnyEvent was invented after Event::RPC was created and thus Event::RPC started using it's own abstraction model. =head1 DESCRIPTION Event::RPC consists of a server and a client library. The server exports a list of classes and methods, which are allowed to be called over the network. More specific it acts as a proxy for objects created on the server side (on demand of the connected clients) which handles client side methods calls with transport of method arguments and return values. The object proxy handles refcounting and destruction of objects created by clients properly. Objects as method parameters and return values are handled as well (although with some limitations, see below). For the client the whole thing is totally transparent - once connected to the server it doesn't know whether it calls methods on local or remote objects. Also the methods on the server newer know whether they are called locally or from a connected client. Your application logic is not affected by Event::RPC at all, at least if it has a rudimentary clean OO design. For details on implementing servers and clients please refer to the man pages of Event::RPC::Server and Event::RPC::Client. =head1 REQUIREMENTS Event::RPC needs either one of the following modules on the server (they're not necessary on the client): Event Glib AnyEvent They're needed for event handling resp. mainloop implementation. If you like to use SSL encryption you need to install IO::Socket::SSL Event::RPC needs minimum one of the following modules for data serialisation: Sereal (::Decoder and ::Encoder) CBOR::XS JSON::XS Storable Server and client negotiate automatically which serialiser to use to achieve maximum compatibility. Some words about the Storable module: it's known to be insecure, so Event::RPC uses it as the last option. You can even prevent Event::RPC from using it at all (even when it's installed, which is the case for nearly every Perl installation) - check manpages of Event::Server and Event::Client about the details. In case you use Storable take care that both client and server use B! Otherwise Event::RPC client/server communication will fail badly. =head1 INSTALLATION You get the latest installation tarballs and online documentation at this location: http://www.exit1.org/Event-RPC/ If your system meets the requirements mentioned above, installation is just: perl Makefile.PL make test make install To test a specific Event loop implementation, export the variable EVENT_RPC_LOOP: export EVENT_RPC_LOOP=Event::RPC::Loop::Glib make test Otherwise Event::RPC will fallback to the most appropriate module installed on your system. =head1 EXAMPLES The tarball includes an examples/ directory which contains two programs: server.pl client.pl Just execute them with --help to get the usage. They do some very simple communication but are good to test your setup, in particular in a mixed environment. =head1 LIMITATIONS Although the classes and objects on the server are accessed transparently by the client there are some limitations should be aware of. With a clean object oriented design these should be no problem in real applications: =head2 Direct object data manipulation is forbidden All objects reside on the server and they keep there! The client just has specially wrapped proxy objects, which trigger the necessary magic to access the object's B on the server. Complete objects are never transferred from the server to the client, so something like this does B work: $object->{data} = "changed data"; (assuming $object is a hash ref on the server). Only method calls are transferred to the server, so even for "simple" data manipulation a method call is necessary: $object->set_data ("changed data"); As well for reading an object attribute. Accessing a hash key will fail: my $data = $object->{data}; Instead call a method which returns the 'data' member: my $data = $object->get_data; =head2 Methods may exchange objects, but not in a too complex structure Event::RPC handles methods which return objects. The only requirement is that they are declared as a B on the server (refer to Event::RPC::Server for details), but not if the object is hidden inside a deep complex data structure. An array or hash ref of objects is Ok, but not more. This would require to much expensive runtime data inspection. Object receiving parameters are more restrictive, since even hiding them inside one array or hash ref is not allowed. They must be passed as a direkt argument of the method subroutine. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/0000755000175000017500000000000013314763036014433 5ustar joernjoernEvent-RPC-1.10/lib/Event/RPC/Loop/0000755000175000017500000000000013314763036015344 5ustar joernjoernEvent-RPC-1.10/lib/Event/RPC/Loop/Event.pm0000644000175000017500000000445012601723500016754 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Loop::Event; use base qw( Event::RPC::Loop ); use strict; use utf8; use Event; sub add_io_watcher { my $self = shift; my %par = @_; my ($fh, $cb, $desc, $poll) = @par{'fh','cb','desc','poll'}; return Event->io ( fd => $fh, poll => $poll, cb => $cb, desc => $desc, reentrant => 0, parked => 0, ); } sub del_io_watcher { my $self = shift; my ($watcher) = @_; $watcher->cancel; 1; } sub add_timer { my $self = shift; my %par = @_; my ($interval, $after, $cb, $desc) = @par{'interval','after','cb','desc'}; die "interval and after can't be used together" if $interval && $after; return Event->timer ( interval => $interval, after => $after, cb => $cb, desc => $desc, ); } sub del_timer { my $self = shift; my ($timer) = @_; $timer->cancel; 1; } sub enter { my $self = shift; Event::loop(); 1; } sub leave { my $self = shift; Event::unloop_all("ok"); 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Loop::Event - Event mainloop for Event::RPC =head1 SYNOPSIS use Event::RPC::Server; use Event::RPC::Loop::Event; my $server = Event::RPC::Server->new ( ... loop => Event::RPC::Loop::Event->new(), ... ); $server->start; =head1 DESCRIPTION This modules implements a mainloop using the Event module for the Event::RPC::Server module. It implements the interface of Event::RPC::Loop. Please refer to the manpage of Event::RPC::Loop for details. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Loop/Glib.pm0000644000175000017500000000536412601723500016555 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Loop::Glib; use base qw( Event::RPC::Loop ); use strict; use utf8; use Glib; sub get_glib_main_loop { shift->{glib_main_loop} } sub set_glib_main_loop { shift->{glib_main_loop} = $_[1] } sub add_io_watcher { my $self = shift; my %par = @_; my ($fh, $cb, $desc, $poll) = @par{'fh','cb','desc','poll'}; my $cond = $poll eq 'r' ? ['G_IO_IN', 'G_IO_HUP']: ['G_IO_OUT','G_IO_HUP']; return Glib::IO->add_watch ($fh->fileno, $cond, sub { &$cb(); 1 } ); } sub del_io_watcher { my $self = shift; my ($watcher) = @_; Glib::Source->remove ($watcher); 1; } sub add_timer { my $self = shift; my %par = @_; my ($interval, $after, $cb, $desc) = @par{'interval','after','cb','desc'}; die "interval and after can't be used together" if $interval && $after; if ( $interval ) { return Glib::Timeout->add ( $interval * 1000, sub { &$cb(); 1 } ); } else { return Glib::Timeout->add ( $after * 1000, sub { &$cb(); 0 } ); } 1; } sub del_timer { my $self = shift; my ($timer) = @_; Glib::Source->remove($timer); 1; } sub enter { my $self = shift; Glib->install_exception_handler(sub { print "Event::RPC::Loop::Glib caught an exception: $@\n"; 1; }); my $main_loop = Glib::MainLoop->new; $self->set_glib_main_loop($main_loop); $main_loop->run; 1; } sub leave { my $self = shift; $self->get_glib_main_loop->quit; 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Loop::Glib - Glib mainloop for Event::RPC =head1 SYNOPSIS use Event::RPC::Server; use Event::RPC::Loop::Glib; my $server = Event::RPC::Server->new ( ... loop => Event::RPC::Loop::Glib->new(), ... ); $server->start; =head1 DESCRIPTION This modules implements a mainloop using Glib for the Event::RPC::Server module. It implements the interface of Event::RPC::Loop. Please refer to the manpage of Event::RPC::Loop for details. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Loop/AnyEvent.pm0000644000175000017500000000474312601723500017431 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Loop::AnyEvent; use base qw( Event::RPC::Loop ); use strict; use utf8; use AnyEvent; my %watchers; sub get_loop_cv { shift->{loop_cv} } sub set_loop_cv { shift->{loop_cv} = $_[1] } sub add_io_watcher { my $self = shift; my %par = @_; my ($fh, $cb, $desc, $poll) = @par{'fh','cb','desc','poll'}; my $watcher = AnyEvent->io ( fh => $fh, poll => $poll, cb => $cb, ); $watchers{"$watcher"} = $watcher; return $watcher; } sub del_io_watcher { my $self = shift; my ($watcher) = @_; delete $watchers{"$watcher"}; 1; } sub add_timer { my $self = shift; my %par = @_; my ($interval, $after, $cb, $desc) = @par{'interval','after','cb','desc'}; my $timer = AnyEvent->timer ( after => $after, interval => $interval, cb => $cb, ); $watchers{"$timer"} = $timer; return $timer; } sub del_timer { my $self = shift; my ($timer) = @_; delete $watchers{"$timer"}; 1; } sub enter { my $self = shift; my $loop_cv = AnyEvent->condvar; $self->set_loop_cv($loop_cv); $loop_cv->wait; 1; } sub leave { my $self = shift; $self->get_loop_cv->send; 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Loop::AnyEvent - AnyEvent mainloop for Event::RPC =head1 SYNOPSIS use Event::RPC::Server; use Event::RPC::Loop::AnyEvent; my $server = Event::RPC::Server->new ( ... loop => Event::RPC::Loop::AnyEvent->new(), ... ); $server->start; =head1 DESCRIPTION This modules implements a mainloop using AnyEvent for the Event::RPC::Server module. It implements the interface of Event::RPC::Loop. Please refer to the manpage of Event::RPC::Loop for details. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message.pm0000644000175000017500000001177713144107350016362 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message; use Carp; use strict; use utf8; my $DEBUG = 0; my $MAX_PACKET_SIZE = 2*1024*1024*1024; sub get_sock { shift->{sock} } sub get_buffer { shift->{buffer} } sub get_length { shift->{length} } sub get_written { shift->{written} } sub set_buffer { shift->{buffer} = $_[1] } sub set_length { shift->{length} = $_[1] } sub set_written { shift->{written} = $_[1] } sub get_max_packet_size { return $MAX_PACKET_SIZE; } sub set_max_packet_size { my $class = shift; my ($value) = @_; $MAX_PACKET_SIZE = $value; } sub new { my $class = shift; my ($sock) = @_; my $self = bless { sock => $sock, buffer => undef, length => 0, written => 0, }, $class; return $self; } sub read { my $self = shift; my ($blocking) = @_; $self->get_sock->blocking($blocking?1:0); if ( not defined $self->{buffer} ) { my $length_packed; $DEBUG && print "DEBUG: going to read header...\n"; my $rc = sysread ($self->get_sock, $length_packed, 4); $DEBUG && print "DEBUG: header read rc=$rc\n"; die "DISCONNECTED" if !(defined $rc) || $rc == 0; $self->{length} = unpack("N", $length_packed); $DEBUG && print "DEBUG: packet size=$self->{length}\n"; die "Incoming message size exceeds limit of $MAX_PACKET_SIZE bytes" if $self->{length} > $MAX_PACKET_SIZE; } my $buffer_length = length($self->{buffer}||''); $DEBUG && print "DEBUG: going to read packet... (buffer_length=$buffer_length)\n"; my $rc = sysread ( $self->get_sock, $self->{buffer}, $self->{length} - $buffer_length, $buffer_length ); $DEBUG && print "DEBUG: packet read rc=$rc\n"; return if not defined $rc; die "DISCONNECTED" if $rc == 0; $buffer_length = length($self->{buffer}); $DEBUG && print "DEBUG: more to read... ($self->{length} != $buffer_length)\n" if $self->{length} != $buffer_length; return if $self->{length} != $buffer_length; $DEBUG && print "DEBUG: read finished, length=$buffer_length\n"; my $data = $self->decode_message($self->{buffer}); $self->{buffer} = undef; $self->{length} = 0; return $data; } sub read_blocked { my $self = shift; my $rc; $rc = $self->read(1) while not defined $rc; return $rc; } sub set_data { my $self = shift; my ($data) = @_; $DEBUG && print "DEBUG: Message->set_data($data)\n"; my $packed = $self->encode_message($data); if ( length($packed) > $MAX_PACKET_SIZE ) { Event::RPC::Server->instance->log("ERROR: response packet exceeds limit of $MAX_PACKET_SIZE bytes"); $data = { rc => 0, msg => "Response packed exceeds limit of $MAX_PACKET_SIZE bytes" }; $packed = $self->encode_message($data); } $self->{buffer} = pack("N", length($packed)).$packed; $self->{length} = length($self->{buffer}); $self->{written} = 0; 1; } sub write { my $self = shift; my ($blocking) = @_; $self->get_sock->blocking($blocking?1:0); my $rc = syswrite ( $self->get_sock, $self->{buffer}, $self->{length}-$self->{written}, $self->{written}, ); $DEBUG && print "DEBUG: written rc=$rc\n"; return if not defined $rc; $self->{written} += $rc; if ( $self->{written} == $self->{length} ) { $DEBUG && print "DEBUG: write finished\n"; $self->{buffer} = undef; $self->{length} = 0; return 1; } $DEBUG && print "DEBUG: more to be written...\n"; return; } sub write_blocked { my $self = shift; my ($data) = @_; $self->set_data($data); my $finished = 0; $finished = $self->write(1) while not $finished; 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message - Implementation of Event::RPC network protocol =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the network protocol of Event::RPC. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/0000755000175000017500000000000013314763036016017 5ustar joernjoernEvent-RPC-1.10/lib/Event/RPC/Message/Sereal.pm0000644000175000017500000000273712601723500017567 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::Sereal; use base Event::RPC::Message; use strict; use utf8; use Sereal qw(sereal_encode_with_object sereal_decode_with_object); my $decoder = Sereal::Decoder->new; my $encoder = Sereal::Encoder->new; sub decode_message { sereal_decode_with_object($decoder, $_[1]) } sub encode_message { sereal_encode_with_object($encoder, $_[1]) } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::Sereal - Sereal message formatting =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the message formatting of Event::RPC using Sereal. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/SerialiserBase.pm0000644000175000017500000000401612601723500021241 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::SerialiserBase; use base Event::RPC::Message; use strict; use utf8; sub UNIVERSAL::FREEZE { my ($object, $serialiser) = @_; my ($ref_type) = "$object" =~ /=(\w+)\(/; return $ref_type eq 'HASH' ? [ $ref_type, [%{$object}] ] : $ref_type eq 'ARRAY' ? [ $ref_type, [@{$object}] ] : $ref_type eq 'SCALAR' ? [ $ref_type, ${$object} ] : die "Unsupported reference type '$ref_type'"; } sub UNIVERSAL::THAW { my ($class, $serialiser, $obj) = @_; return $obj->[0] eq 'HASH' ? bless { @{$obj->[1]} }, $class : $obj->[0] eq 'ARRAY' ? bless [ @{$obj->[1]} ], $class : $obj->[0] eq 'SCALAR' ? bless \ $obj->[1], $class : die "Unsupported reference type '$obj->[0]'"; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::SerialiserBase - Base for some message classes =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements universal FREEZE/THAW methodes for JSON and CBOR based message format classes. Unfortunately these modules can't take callbacks for these tasks but require to pollute UNIVERSAL namespace for this, so when loading several modules overriding these methodes by each other throw warnings. This module exist just to prevent these. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/CBOR.pm0000644000175000017500000000251112601723500017067 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::CBOR; use base Event::RPC::Message::SerialiserBase; use strict; use utf8; use CBOR::XS; my $cbor = CBOR::XS->new; sub decode_message { $cbor->decode($_[1]) } sub encode_message { $cbor->encode($_[1]) } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::CBOR - CBOR message formatting =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the message formatting of Event::RPC using CBOR. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/Storable.pm0000644000175000017500000000311512601723500020116 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::Storable; use base Event::RPC::Message; use strict; use utf8; use Storable; sub decode_message { Storable::thaw($_[1]) } sub encode_message { Storable::nfreeze ($_[1]) } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::Storable - Storable message formatting =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the message formatting of Event::RPC using Storable. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 IMPORTANT NOTE This module is shipped for client/server backward compatibility with Event::RPC prior to 1.06. Due to security considerations it's not recommended to use Storable in real world szenarios. Better use one of the other alternatives (Sereal, CBOR or JSON). =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/Negotiate.pm0000644000175000017500000000532612601723500020270 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::Negotiate; use base Event::RPC::Message; use Carp; use strict; use utf8; my %MESSAGE_FORMATS = ( "SERL" => "Event::RPC::Message::Sereal", "CBOR" => "Event::RPC::Message::CBOR", "JSON" => "Event::RPC::Message::JSON", "STOR" => "Event::RPC::Message::Storable", ); my @MESSAGE_FORMAT_ORDER = qw( SERL CBOR JSON STOR ); sub known_message_formats { \%MESSAGE_FORMATS } sub message_format_order { \@MESSAGE_FORMAT_ORDER } my $STORABLE_FALLBACK_OK = 0; sub get_storable_fallback_ok { $STORABLE_FALLBACK_OK } sub set_storable_fallback_ok { $STORABLE_FALLBACK_OK = $_[1] } sub encode_message { my $self = shift; my ($decoded) = @_; my $ok = $decoded->{ok} || ""; my $msg = $decoded->{msg} || ""; my $cmd = $decoded->{cmd} || ""; s,/\d/,,g for ( $ok, $msg, $cmd ); return "/0/E:R:M:N/1/$ok/2/$msg/3/$cmd/0/"; } sub decode_message { my $self = shift; my ($encoded) = @_; return { ok => $1, msg => $2, cmd => $3 } if $encoded =~ m,^/0/E:R:M:N/1/(.*?)/2/(.*?)/3/(.*?)/0/$,; #-- An old client or server may not know our message #-- format negotiation protocol, so we provide a Storable #-- fallback mechanism, if we're allowed to do so. if ( $self->get_storable_fallback_ok ) { require Event::RPC::Message::Storable; bless $self, "Event::RPC::Message::Storable"; return $self->decode_message($encoded); } #-- No Storable fallback allowed. We bail out! die "Error on message format negotitation and no fallback to Storable allowed\n"; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::Negotiate - Message format negotiation protocol =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the message format negotitation protocol of Event::RPC. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Message/JSON.pm0000644000175000017500000000264212601723500017120 0ustar joernjoern# $Id: Message.pm,v 1.9 2014-01-28 15:40:10 joern Exp $ #----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Message::JSON; use base Event::RPC::Message::SerialiserBase; use strict; use utf8; use JSON::XS 3.0; my $decoder = JSON::XS->new->allow_tags; my $encoder = JSON::XS->new->latin1->allow_blessed->allow_tags; sub decode_message { $decoder->decode($_[1]) } sub encode_message { $encoder->encode($_[1]) } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Message::JSON - JSON message formatting =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION This module implements the message formatting of Event::RPC using JSON. Objects of this class are created internally by Event::RPC::Server and Event::RPC::Client and performs message passing over the network. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Connection.pm0000644000175000017500000004565512601723500017075 0ustar joernjoernpackage Event::RPC::Connection; use strict; use utf8; use Carp; use Event::RPC::Message::Negotiate; #-- This can be changed for testing purposes e.g. to simulate #-- old servers which don't perform any format negotitation. $Event::RPC::Server::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Negotiate"; my $CONNECTION_ID; sub get_cid { shift->{cid} } sub get_sock { shift->{sock} } sub get_server { shift->{server} } sub get_classes { shift->{server}->{classes} } sub get_loaded_classes { shift->{server}->{loaded_classes} } sub get_objects { shift->{server}->{objects} } sub get_client_oids { shift->{client_oids} } sub get_message_format { shift->{message_format} } sub get_watcher { shift->{watcher} } sub get_write_watcher { shift->{write_watcher} } sub get_message { shift->{message} } sub get_is_authenticated { shift->{is_authenticated} } sub get_auth_user { shift->{auth_user} } sub set_message_format { shift->{message_format} = $_[1] } sub set_watcher { shift->{watcher} = $_[1] } sub set_write_watcher { shift->{write_watcher} = $_[1] } sub set_message { shift->{message} = $_[1] } sub set_is_authenticated { shift->{is_authenticated} = $_[1] } sub set_auth_user { shift->{auth_user} = $_[1] } sub new { my $class = shift; my ($server, $sock) = @_; my $cid = ++$CONNECTION_ID; my $self = bless { cid => $cid, sock => $sock, server => $server, is_authenticated => (!$server->get_auth_required), auth_user => "", watcher => undef, write_watcher => undef, message => undef, client_oids => {}, message_format => $Event::RPC::Server::DEFAULT_MESSAGE_FORMAT, }, $class; if ( $sock ) { $self->log (2, "Got new RPC connection. Connection ID is $cid" ); $self->{watcher} = $self->get_server->get_loop->add_io_watcher ( fh => $sock, poll => 'r', cb => sub { $self->input; 1 }, desc => "rpc client cid=$cid", ); } my $connection_hook = $server->get_connection_hook; &$connection_hook($self, "connect") if $connection_hook; return $self; } sub disconnect { my $self = shift; $self->get_server->get_loop->del_io_watcher($self->get_watcher); $self->get_server->get_loop->del_io_watcher($self->get_write_watcher) if $self->get_write_watcher; $self->set_watcher(undef); $self->set_write_watcher(undef); close $self->get_sock; my $server = $self->get_server; $server->set_clients_connected ( $self->get_server->get_clients_connected - 1 ); foreach my $oid ( keys %{$self->get_client_oids} ) { $server->deregister_object($oid); } $self->log(2, "Client disconnected"); my $connection_hook = $server->get_connection_hook; &$connection_hook($self, "disconnect") if $connection_hook; 1; } sub get_client_object { my $self = shift; my ($oid) = @_; croak "No object registered with oid '$oid'" unless $self->get_client_objects->{$oid}; return $self->get_client_objects->{$oid}; } sub log { my $self = shift; my ($level, $msg); if ( @_ == 2 ) { ($level, $msg) = @_; } else { ($msg) = @_; $level = 1; } $msg = "cid=".$self->get_cid.": $msg"; return $self->get_server->log ($level, $msg); } sub input { my $self = shift; my ($e) = @_; my $server = $self->get_server; my $message = $self->get_message; if ( not $message ) { $message = $self->get_message_format->new ($self->get_sock); $self->set_message($message); } my $request = eval { $message->read } || ''; my $error = $@; return if $request eq '' && $error eq ''; $self->set_message(undef); return $self->disconnect if $request eq "DISCONNECT\n" or $error =~ /DISCONNECTED/; $server->set_active_connection($self); my ($cmd, $rc); $cmd = $request->{cmd} if not $error; $self->log(4, "RPC command: $cmd"); if ( $error ) { $self->log ("Unexpected error on incoming RPC call: $@"); $rc = { ok => 0, msg => "Unexpected error on incoming RPC call: $@", }; } elsif ( $cmd eq 'neg_formats_avail') { $rc = { ok => 1, msg => join(",", @{$self->get_server->get_message_formats}) }; } elsif ( $cmd eq 'neg_format_set') { $rc = $self->client_requests_message_format($request->{msg}); } elsif ( $cmd eq 'version' ) { #-- Probably we have fallen back to Storable because an old #-- client has connected. so we change the negotiation #-- message handler to the fallback handler for further #-- communication on this connection. $self->set_message_format(ref $message); $rc = { ok => 1, version => $Event::RPC::VERSION, protocol => $Event::RPC::PROTOCOL, }; } elsif ( $cmd eq 'auth' ) { $rc = $self->authorize_user ($request); } elsif ( $server->get_auth_required && !$self->get_is_authenticated ) { $rc = { ok => 0, msg => "Authorization required", }; } elsif ( $cmd eq 'new' ) { $rc = $self->create_new_object ($request); } elsif ( $cmd eq 'exec' ) { $rc = $self->execute_object_method ($request); } elsif ( $cmd eq 'classes_list' ) { $rc = $self->get_classes_list ($request); } elsif ( $cmd eq 'class_info' ) { $rc = $self->get_class_info ($request); } elsif ( $cmd eq 'class_info_all' ) { $rc = $self->get_class_info_all ($request); } elsif ( $cmd eq 'client_destroy' ) { $rc = $self->object_destroyed_on_client ($request); } else { $self->log ("Unknown request command '$cmd'"); $rc = { ok => 0, msg => "Unknown request command '$cmd'", }; } $server->set_active_connection(undef); $message->set_data($rc); my $watcher = $self->get_server->get_loop->add_io_watcher ( fh => $self->get_sock, poll => 'w', cb => sub { if ( $message->write ) { $self->get_server->get_loop->del_io_watcher($self->get_write_watcher) if $self->get_write_watcher; $self->set_write_watcher(); } 1; }, ); $self->set_write_watcher($watcher); 1; } sub client_requests_message_format { my $self = shift; my ($client_format) = @_; foreach my $format ( @{$self->get_server->get_message_formats} ) { if ( $client_format eq $format ) { $self->set_message_format( Event::RPC::Message::Negotiate->known_message_formats ->{$client_format} ); eval "use ".$self->get_message_format; return { ok => 0, msg => "Server rejected format '$client_format': $@" } if $@; return { ok => 1 }; } } return { ok => 0, msg => "Server rejected format '$client_format'" }; } sub authorize_user { my $self = shift; my ($request) = @_; my $user = $request->{user}; my $pass = $request->{pass}; my $auth_module = $self->get_server->get_auth_module; return { ok => 1, msg => "Not authorization required", } unless $auth_module; my $ok = $auth_module->check_credentials ($user, $pass); if ( $ok ) { $self->set_auth_user($user); $self->set_is_authenticated(1); $self->log("User '$user' successfully authorized"); return { ok => 1, msg => "Credentials Ok", }; } else { $self->log("Illegal credentials for user '$user'"); return { ok => 0, msg => "Illegal credentials", }; } } sub create_new_object { my $self = shift; my ($request) = @_; # Let's create a new object my $class_method = $request->{method}; my $class = $class_method; $class =~ s/::[^:]+$//; $class_method =~ s/^.*:://; # check if access to this class/method is allowed if ( not defined $self->get_classes->{$class}->{$class_method} or $self->get_classes->{$class}->{$class_method} ne '_constructor' ) { $self->log ("Illegal constructor access to $class->$class_method"); return { ok => 0, msg => "Illegal constructor access to $class->$class_method" }; } # ok, load class and execute the method my $object = eval { # load the class if not done yet $self->load_class($class) if $self->get_server->get_load_modules; # resolve object params $self->resolve_object_params ($request->{params}); $class->$class_method (@{$request->{params}}) }; # report error if ( $@ ) { $self->log ("Error: can't create object ". "($class->$class_method): $@"); return { ok => 0, msg => $@, }; } # register object $self->get_server->register_object ($object, $class); $self->get_client_oids->{"$object"} = 1; # log and return $self->log (5, "Created new object $class->$class_method with oid '$object'", ); return { ok => 1, oid => "$object", }; } sub load_class { my $self = shift; my ($class) = @_; my $mtime; my $load_class_info = $self->get_loaded_classes->{$class}; if ( not $load_class_info or ( $self->get_server->get_auto_reload_modules && ( $mtime = (stat($load_class_info->{filename}))[9]) > $load_class_info->{mtime} ) ) { if ( not $load_class_info->{filename} ) { my $filename; my $rel_filename = $class; $rel_filename =~ s!::!/!g; $rel_filename .= ".pm"; foreach my $dir ( @INC ) { $filename = "$dir/$rel_filename", last if -f "$dir/$rel_filename"; } croak "File for class '$class' not found\n" if not $filename; $load_class_info->{filename} = $filename; $load_class_info->{mtime} = 0; } $mtime ||= 0; $self->log (3, "Class '$class' ($load_class_info->{filename}) changed on disk. Reloading...") if $mtime > $load_class_info->{mtime}; do $load_class_info->{filename}; if ( $@ ) { $self->log ("Can't load class '$class': $@"); $load_class_info->{mtime} = 0; die "Can't load class $class: $@"; } else { $self->log (3, "Class '$class' successfully loaded"); $load_class_info->{mtime} = time; } } $self->log (5, "filename=".$load_class_info->{filename}. ", mtime=".$load_class_info->{mtime} ); $self->get_loaded_classes->{$class} ||= $load_class_info; 1; } sub execute_object_method { my $self = shift; my ($request) = @_; # Method call of an existent object my $oid = $request->{oid}; my $object_entry = $self->get_objects->{$oid}; my $method = $request->{method}; if ( not defined $object_entry ) { # object does not exist $self->log ("Illegal access to unknown object with oid=$oid"); return { ok => 0, msg => "Illegal access to unknown object with oid=$oid" }; } my $class = $object_entry->{class}; if ( not defined $self->get_classes->{$class} or not defined $self->get_classes->{$class}->{$method} ) { # illegal access to this method $self->log ("Illegal access to $class->$method"); return { ok => 0, msg => "Illegal access to $class->$method" }; } my $return_type = $self->get_classes->{$class}->{$method}; # ok, try loading class and executing the method my @rc = eval { # (re)load the class if not done yet $self->load_class($class) if $self->get_server->get_load_modules; # resolve object params $self->resolve_object_params ($request->{params}); # exeute method $object_entry->{object}->$method (@{$request->{params}}) }; # report error if ( $@ ) { $self->log ("Error: can't call '$method' of object ". "with oid=$oid: $@"); return { ok => 0, msg => "$@", }; } # log $self->log (4, "Called method '$method' of object ". "with oid=$oid"); if ( $return_type eq '_object' ) { # check if objects are returned by this method # and register them in our internal object table # (if not already done yet) my $key; foreach my $rc ( @rc ) { if ( ref ($rc) and ref ($rc) !~ /ARRAY|HASH|SCALAR/ ) { # returns a single object $self->log (4, "Method returns object: $rc"); $key = "$rc"; $self->get_client_oids->{$key} = 1; $self->get_server->register_object($rc, ref $rc); $rc = $key; } elsif ( ref $rc eq 'ARRAY' ) { # possibly returns a list of objects # make a copy, otherwise the original object references # will be overwritten my @val = @{$rc}; $rc = \@val; foreach my $val ( @val ) { if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) { $self->log (4, "Method returns object lref: $val"); $key = "$val"; $self->get_client_oids->{$key} = 1; $self->get_server->register_object($val, ref $val); $val = $key; } } } elsif ( ref $rc eq 'HASH' ) { # possibly returns a hash of objects # make a copy, otherwise the original object references # will be overwritten my %val = %{$rc}; $rc = \%val; foreach my $val ( values %val ) { if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) { $self->log (4, "Method returns object href: $val"); $key = "$val"; $self->get_client_oids->{$key} = 1; $self->get_server->register_object($val, ref $val); $val = $key; } } } } } # return rc return { ok => 1, rc => \@rc, }; } sub object_destroyed_on_client { my $self = shift; my ($request) = @_; $self->log(5, "Object with oid=$request->{oid} destroyed on client"); delete $self->get_client_oids->{$request->{oid}}; $self->get_server->deregister_object($request->{oid}); return { ok => 1 }; } sub get_classes_list { my $self = shift; my ($request) = @_; my @classes = keys %{$self->get_classes}; return { ok => 1, classes => \@classes, } } sub get_class_info { my $self = shift; my ($request) = @_; my $class = $request->{class}; if ( not defined $self->get_classes->{$class} ) { $self->log ("Unknown class '$class'"); return { ok => 0, msg => "Unknown class '$class'" }; } $self->log (4, "Class info for '$class' requested"); return { ok => 1, methods => $self->get_classes->{$class}, }; } sub get_class_info_all { my $self = shift; my ($request) = @_; return { ok => 1, class_info_all => $self->get_classes, } } sub resolve_object_params { my $self = shift; my ($params) = @_; my $key; foreach my $par ( @{$params} ) { if ( defined $self->get_classes->{ref($par)} ) { $key = ${$par}; $key = "$key"; croak "unknown object with key '$key'" if not defined $self->get_objects->{$key}; $par = $self->get_objects->{$key}->{object}; } } 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Connection - Represents a RPC connection =head1 SYNOPSIS Note: you never create instances of this class in your own code, it's only used internally by Event::RPC::Server. But you may request connection objects using the B of Event::RPC::Server and then having some read access on them. my $connection = Event::RPC::Server::Connection->new ( $rpc_server, $client_socket ); As well you can get the currently active connection from your Event::RPC::Server object: my $server = Event::RPC::Server->instance; my $connection = $server->get_active_connection; =head1 DESCRIPTION Objects of this class represents a connection from an Event::RPC::Client to an Event::RPC::Server instance. They live inside the server and the whole Client/Server protocol is implemented here. =head1 READ ONLY ATTRIBUTES The following attributes may be read using the corresponding get_ATTRIBUTE accessors: =over 4 =item B The connection ID of this connection. A number which is unique for this server instance. =item B The Event::RPC::Server instance this connection belongs to. =item B This boolean value reflects whether the connection is authenticated resp. whether the client passed correct credentials. =item B This is the name of the user who was authenticated successfully for this connection. =item B This is a hash reference of object id's which are in use by the client of this connection. Keys are the object ids, value is always 1. You can get the corresponding objects by using the $connection->get_client_object($oid) method. Don't change anything in this hash, in particular don't delete or add entries. Event::RPC does all the necessary garbage collection transparently, no need to mess with that. =back =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/LogConnection.pm0000644000175000017500000000440612601723500017524 0ustar joernjoernpackage Event::RPC::LogConnection; use Carp; use strict; use utf8; use Socket; my $LOG_CONNECTION_ID; sub get_cid { shift->{cid} } sub get_sock { shift->{sock} } sub get_server { shift->{server} } sub get_watcher { shift->{watcher} } sub set_watcher { shift->{watcher} = $_[1] } sub new { my $class = shift; my ($server, $sock) = @_; my $cid = ++$LOG_CONNECTION_ID; my $self = bless { cid => $cid, sock => $sock, server => $server, watcher => undef, }, $class; $self->{watcher} = $server->get_loop->add_io_watcher( fh => $sock, poll => 'r', cb => sub { $self->input; 1 }, desc => "log reader $cid", ); $self->get_server->log (2, "Got new logger connection. Connection ID is $cid" ); return $self; } sub disconnect { my $self = shift; my $sock = $self->get_sock; $self->get_server->get_logger->remove_fh($sock) if $self->get_server->get_logger; $self->get_server->get_loop->del_io_watcher($self->get_watcher); $self->set_watcher(undef); close $sock; $self->get_server->set_log_clients_connected ( $self->get_server->get_log_clients_connected - 1 ); delete $self->get_server->get_logging_clients->{$self->get_cid}; $self->get_server->log(2, "Log client disconnected"); 1; } sub input { my $self = shift; my $buffer; $self->disconnect if not sysread($self->get_sock, $buffer, 4096); 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::LogConnection - Represents a logging connection =head1 SYNOPSIS # Internal module. No documented public interface. =head1 DESCRIPTION Objects of this class are created by Event::RPC server if a client connects to the logging port of the server. It's an internal module and has no public interface. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Logger.pm0000644000175000017500000001052012601723500016174 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Logger; use strict; use utf8; use FileHandle; sub get_filename { shift->{filename} } sub get_filename_fh { shift->{filename_fh} } sub get_fh_lref { shift->{fh_lref} } sub get_min_level { shift->{min_level} } sub set_fh_lref { shift->{fh_lref} = $_[1] } sub set_min_level { shift->{min_level} = $_[1] } sub new { my $class = shift; my %par = @_; my ($filename, $fh_lref, $min_level) = @par{'filename','fh_lref','min_level'}; my $filename_fh; if ( $filename ) { $filename_fh = FileHandle->new; open ($filename_fh, ">>$filename") or die "can't write log $filename"; $filename_fh->autoflush(1); } if ( $fh_lref ) { foreach my $fh ( @{$fh_lref} ) { my $old_fh = select $fh; $| = 1; select $old_fh; } } else { $fh_lref = []; } my $self = bless { filename => $filename, filename_fh => $filename_fh, fh_lref => $fh_lref, min_level => $min_level, }, $class; return $self; } sub DESTROY { my $self = shift; my $filename_fh = $self->get_filename_fh; close $filename_fh if $filename_fh; 1; } sub log { my $self = shift; my ($level, $msg); if ( @_ == 2 ) { $level = $_[0]; $msg = $_[1]; } else { $level = 1; $msg = $_[0]; } return if $level > $self->get_min_level; $msg .= "\n" if $msg !~ /\n$/; my $str = localtime(time)." [$level] $msg"; for my $fh ( @{$self->get_fh_lref} ) { print $fh $str if $fh; } my $fh = $self->get_filename_fh; print $fh $str if $fh; 1; } sub add_fh { my $self = shift; my ($fh) = @_; push @{$self->get_fh_lref}, $fh; 1; } sub remove_fh { my $self = shift; my ($fh) = @_; my $fh_lref = $self->get_fh_lref; my $i; for ( $i=0; $i<@{$fh_lref}; ++$i ) { last if $fh_lref->[$i] eq $fh; } return if $i == @{$fh_lref}; splice @{$fh_lref}, $i, 1; 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Logger - Logging facility for Event::RPC =head1 SYNOPSIS use Event::RPC::Server; use Event::RPC::Logger; my $server = Event::RPC::Server->new ( ... logger => Event::RPC::Logger->new( filename => "/var/log/myserver.log", fh_lref => [ $fh, $sock ], min_level => 2, ), ... ); $server->start; =head1 DESCRIPTION This modules implements a simple logging facility for the Event::RPC framework. Log messages may be written to a specific file and/or a bunch of filehandles, which may be sockets as well. =head1 CONFIGURATION OPTIONS This is a list of options you can pass to the new() constructor: =over 4 =item B All log messages are appended to this file. =item B All log messages are printed into this list of filehandles. =item B This is the minimum log level. Output of messages with a lower level is suppressed. This option may be altered using set_min_level() even in a running server. =back =head1 METHODS =over 4 =item $logger->B ( [$level, ] $msg ) The log() method does the actual logging. Called with one argument the messages gets the default level of 1. With two argumens the first is the level for the message. =item $logger->B ( $fh ) This adds a filehandle to the internal list of filhandles all log messages are written to. =item $logger->B ( $fh ) Removes a filehandle. =back =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Server.pm0000644000175000017500000007630212663111343016241 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Server; use Event::RPC; use Event::RPC::Connection; use Event::RPC::LogConnection; use Event::RPC::Message::Negotiate; use Carp; use strict; use utf8; use IO::Socket::INET; use Sys::Hostname; sub get_host { shift->{host} } sub get_port { shift->{port} } sub get_name { shift->{name} } sub get_loop { shift->{loop} } sub get_classes { shift->{classes} } sub get_singleton_classes { shift->{singleton_classes} } sub get_loaded_classes { shift->{loaded_classes} } sub get_clients_connected { shift->{clients_connected} } sub get_log_clients_connected { shift->{log_clients_connected} } sub get_logging_clients { shift->{logging_clients} } sub get_logger { shift->{logger} } sub get_start_log_listener { shift->{start_log_listener} } sub get_objects { shift->{objects} } sub get_rpc_socket { shift->{rpc_socket} } sub get_ssl { shift->{ssl} } sub get_ssl_key_file { shift->{ssl_key_file} } sub get_ssl_cert_file { shift->{ssl_cert_file} } sub get_ssl_passwd_cb { shift->{ssl_passwd_cb} } sub get_ssl_opts { shift->{ssl_opts} } sub get_auth_required { shift->{auth_required} } sub get_auth_passwd_href { shift->{auth_passwd_href} } sub get_auth_module { shift->{auth_module} } sub get_listeners_started { shift->{listeners_started} } sub get_connection_hook { shift->{connection_hook} } sub get_load_modules { shift->{load_modules} } sub get_auto_reload_modules { shift->{auto_reload_modules} } sub get_active_connection { shift->{active_connection} } sub get_message_formats { shift->{message_formats} } sub get_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} } sub set_host { shift->{host} = $_[1] } sub set_port { shift->{port} = $_[1] } sub set_name { shift->{name} = $_[1] } sub set_loop { shift->{loop} = $_[1] } sub set_classes { shift->{classes} = $_[1] } sub set_singleton_classes { shift->{singleton_classes} = $_[1] } sub set_loaded_classes { shift->{loaded_classes} = $_[1] } sub set_clients_connected { shift->{clients_connected} = $_[1] } sub set_log_clients_connected { shift->{log_clients_connected}= $_[1] } sub set_logging_clients { shift->{logging_clients} = $_[1] } sub set_logger { shift->{logger} = $_[1] } sub set_start_log_listener { shift->{start_log_listener} = $_[1] } sub set_objects { shift->{objects} = $_[1] } sub set_rpc_socket { shift->{rpc_socket} = $_[1] } sub set_ssl { shift->{ssl} = $_[1] } sub set_ssl_key_file { shift->{ssl_key_file} = $_[1] } sub set_ssl_cert_file { shift->{ssl_cert_file} = $_[1] } sub set_ssl_passwd_cb { shift->{ssl_passwd_cb} = $_[1] } sub set_ssl_opts { shift->{ssl_opts} = $_[1] } sub set_auth_required { shift->{auth_required} = $_[1] } sub set_auth_passwd_href { shift->{auth_passwd_href} = $_[1] } sub set_auth_module { shift->{auth_module} = $_[1] } sub set_listeners_started { shift->{listeners_started} = $_[1] } sub set_connection_hook { shift->{connection_hook} = $_[1] } sub set_load_modules { shift->{load_modules} = $_[1] } sub set_auto_reload_modules { shift->{auto_reload_modules} = $_[1] } sub set_active_connection { shift->{active_connection} = $_[1] } sub set_message_formats { shift->{message_formats} = $_[1] } sub set_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} = $_[1] } my $INSTANCE; sub instance { $INSTANCE } sub get_max_packet_size { return Event::RPC::Message->get_max_packet_size; } sub set_max_packet_size { my $class = shift; my ($value) = @_; Event::RPC::Message->set_max_packet_size($value); } sub new { my $class = shift; my %par = @_; my ($host, $port, $classes, $name, $logger, $start_log_listener) = @par{'host','port','classes','name','logger','start_log_listener'}; my ($ssl, $ssl_key_file, $ssl_cert_file, $ssl_passwd_cb, $ssl_opts) = @par{'ssl','ssl_key_file','ssl_cert_file','ssl_passwd_cb','ssl_opts'}; my ($auth_required, $auth_passwd_href, $auth_module, $loop) = @par{'auth_required','auth_passwd_href','auth_module','loop'}; my ($connection_hook, $auto_reload_modules) = @par{'connection_hook','auto_reload_modules'}; my ($load_modules, $message_formats, $insecure_msg_fmt_ok) = @par{'load_modules','message_formats','insecure_msg_fmt_ok'}; $name ||= "Event-RPC-Server"; $insecure_msg_fmt_ok = 1 unless defined $insecure_msg_fmt_ok; #-- for backwards compatibility 'load_modules' defaults to 1 if ( !exists $par{load_modules} ) { $load_modules = 1; } if ( not $loop ) { foreach my $impl ( qw/AnyEvent Event Glib/ ) { $loop = "Event::RPC::Loop::$impl"; eval "use $loop"; if ( $@ ) { $loop = undef; } else { $loop = $loop->new; last; } } die "It seems no supported event loop module is installed" unless $loop; } my $self = bless { host => $host, port => $port, name => $name, classes => $classes, singleton_classes => {}, logger => $logger, start_log_listener => $start_log_listener, loop => $loop, ssl => $ssl, ssl_key_file => $ssl_key_file, ssl_cert_file => $ssl_cert_file, ssl_passwd_cb => $ssl_passwd_cb, ssl_opts => $ssl_opts, auth_required => $auth_required, auth_passwd_href => $auth_passwd_href, auth_module => $auth_module, load_modules => $load_modules, auto_reload_modules => $auto_reload_modules, connection_hook => $connection_hook, message_formats => $message_formats, insecure_msg_fmt_ok => $insecure_msg_fmt_ok, rpc_socket => undef, loaded_classes => {}, objects => {}, logging_clients => {}, clients_connected => 0, listeners_started => 0, log_clients_connected => 0, active_connection => undef, }, $class; $INSTANCE = $self; $self->log ($self->get_name." started"); return $self; } sub DESTROY { my $self = shift; my $rpc_socket = $self->get_rpc_socket; close ($rpc_socket) if $rpc_socket; 1; } sub probe_message_formats { my $class = shift; my ($user_supplied_formats, $insecure_msg_fmt_ok) = @_; my $order_lref = Event::RPC::Message::Negotiate->message_format_order; my $modules_by_name = Event::RPC::Message::Negotiate->known_message_formats; my %probe_formats; if ( $user_supplied_formats ) { @probe_formats{@{$user_supplied_formats}} = (1) x @{$user_supplied_formats}; } else { %probe_formats = %{$modules_by_name}; } #-- By default we probe all supported formats, but #-- not Storable. User has to activate this explicitely. if ( not $insecure_msg_fmt_ok ) { delete $probe_formats{STOR}; } Event::RPC::Message::Negotiate->set_storable_fallback_ok($insecure_msg_fmt_ok); my @supported_formats; foreach my $name ( @{$order_lref} ) { next unless $probe_formats{$name}; my $module = $modules_by_name->{$name}; eval "use $module"; push @supported_formats, $name unless $@; } return \@supported_formats; } sub setup_listeners { my $self = shift; #-- Listener options my $host = $self->get_host; my $port = $self->get_port; my @LocalHost = $host ? ( LocalHost => $host ) : (); $host ||= "*"; #-- get event loop manager my $loop = $self->get_loop; #-- setup rpc listener my $rpc_socket; if ( $self->get_ssl ) { eval { require IO::Socket::SSL }; croak "SSL requested, but IO::Socket::SSL not installed" if $@; croak "ssl_key_file not set" unless $self->get_ssl_key_file; croak "ssl_cert_file not set" unless $self->get_ssl_cert_file; my $ssl_opts = $self->get_ssl_opts; $rpc_socket = IO::Socket::SSL->new ( Listen => SOMAXCONN, @LocalHost, LocalPort => $port, Proto => 'tcp', ReuseAddr => 1, SSL_key_file => $self->get_ssl_key_file, SSL_cert_file => $self->get_ssl_cert_file, SSL_passwd_cb => $self->get_ssl_passwd_cb, ($ssl_opts?%{$ssl_opts}:()), ) or die "can't start SSL RPC listener: $IO::Socket::SSL::ERROR"; } else { $rpc_socket = IO::Socket::INET->new ( Listen => SOMAXCONN, @LocalHost, LocalPort => $port, Proto => 'tcp', ReuseAddr => 1, ) or die "can't start RPC listener: $!"; } $self->set_rpc_socket($rpc_socket); $loop->add_io_watcher ( fh => $rpc_socket, poll => 'r', cb => sub { $self->accept_new_client($rpc_socket); 1 }, desc => "rpc listener port $port", ); if ( $self->get_ssl ) { $self->log ("Started SSL RPC listener on port $host:$port"); } else { $self->log ("Started RPC listener on $host:$port"); } # setup log listener if ( $self->get_start_log_listener ) { my $log_socket = IO::Socket::INET->new ( Listen => SOMAXCONN, LocalPort => $port + 1, @LocalHost, Proto => 'tcp', ReuseAddr => 1, ) or die "can't start log listener: $!"; $loop->add_io_watcher ( fh => $log_socket, poll => 'r', cb => sub { $self->accept_new_log_client($log_socket); 1 }, desc => "log listener port ".($port+1), ); $self->log ("Started log listener on $host:".($port+1)); } $self->determine_singletons; $self->set_listeners_started(1); 1; } sub setup_auth_module { my $self = shift; #-- Exit if no auth is required or setup already return if not $self->get_auth_required; return if $self->get_auth_module; #-- Default to Event::RPC::AuthPasswdHash require Event::RPC::AuthPasswdHash; #-- Setup an instance my $passwd_href = $self->get_auth_passwd_href; my $auth_module = Event::RPC::AuthPasswdHash->new ($passwd_href); $self->set_auth_module($auth_module); 1; } sub prepare { my $self = shift; $self->setup_listeners unless $self->get_listeners_started; $self->setup_auth_module; #-- Filter unsupported message formats $self->set_message_formats( $self->probe_message_formats( $self->get_message_formats, $self->get_insecure_msg_fmt_ok ) ); 1; } sub start { my $self = shift; #-- Prepare server for startup $self->prepare; my $loop = $self->get_loop; $self->log ("Enter main loop using ".ref($loop)); $loop->enter; $self->log ("Server stopped"); 1; } sub stop { my $self = shift; $self->get_loop->leave; 1; } sub determine_singletons { my $self = shift; my $classes = $self->get_classes; my $singleton_classes = $self->get_singleton_classes; foreach my $class ( keys %{$classes} ) { foreach my $method ( keys %{$classes->{$class}} ) { # check for singleton returner if ( $classes->{$class}->{$method} eq '_singleton' ) { # change to constructor $classes->{$class}->{$method} = '_constructor'; # track that this class is a singleton $singleton_classes->{$class} = 1; last; } } } 1; } sub accept_new_client { my $self = shift; my ($rpc_socket) = @_; my $client_socket = $rpc_socket->accept or return; Event::RPC::Connection->new ($self, $client_socket); $self->set_clients_connected ( 1 + $self->get_clients_connected ); 1; } sub accept_new_log_client { my $self = shift; my ($log_socket) = @_; my $client_socket = $log_socket->accept or return; my $log_client = Event::RPC::LogConnection->new($self, $client_socket); $self->set_log_clients_connected ( 1 + $self->get_log_clients_connected ); $self->get_logging_clients->{$log_client->get_cid} = $log_client; $self->get_logger->add_fh($client_socket) if $self->get_logger; $self->log(2, "New log client connected"); 1; } sub load_class { my $self = shift; my ($class) = @_; Event::RPC::Connection->new ($self)->load_class($class); return $class; } sub log { my $self = shift; my $logger = $self->get_logger; return unless $logger; $logger->log(@_); 1; } sub remove_object { my $self = shift; my ($object) = @_; my $objects = $self->get_objects; if ( not $objects->{"$object"} ) { warn "Object $object not registered"; return; } delete $objects->{"$object"}; $self->log(5, "Object '$object' removed"); 1; } sub register_object { my $self = shift; my ($object, $class) = @_; my $objects = $self->get_objects; my $refcount; if ( $objects->{"$object"} ) { $refcount = ++$objects->{"$object"}->{refcount}; } else { $refcount = 1; $objects->{"$object"} = { object => $object, class => $class, refcount => 1, }; } $self->log(5, "Object '$object' registered. Refcount=$refcount"); 1; } sub deregister_object { my $self = shift; my ($object) = @_; my $objects = $self->get_objects; if ( not $objects->{"$object"} ) { warn "Object $object not registered"; return; } my $refcount = --$objects->{"$object"}->{refcount}; my ($class) = split(/=/, $object); if ( $self->get_singleton_classes->{$class} ) { # never deregister singletons $self->log(4, "Skip deregistration of singleton '$object'"); return; } $self->log(5, "Object '$object' deregistered. Refcount=$refcount"); $self->remove_object($object) if $refcount == 0; 1; } sub print_object_register { my $self = shift; print "-"x70,"\n"; my $objects = $self->get_objects; foreach my $oid ( sort keys %{$objects} ) { print "$oid\t$objects->{$oid}->{refcount}\n"; } 1; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Server - Simple API for event driven RPC servers =head1 SYNOPSIS use Event::RPC::Server; use My::TestModule; my $server = Event::RPC::Server->new ( #-- Required arguments port => 8888, classes => { "My::TestModule" => { new => "_constructor", get_data => 1, set_data => 1, clone => "_object", }, }, #-- Optional arguments name => "Test server", logger => Event::RPC::Logger->new(), start_log_listener => 1, ssl => 1 ssl_key_file => "server.key", ssl_cert_file => "server.crt", ssl_passwd_cb => sub { "topsecret" }, ssl_opts => { ... }, auth_required => 1, auth_passwd_href => { $user => Event::RPC->crypt($user,$pass) }, auth_module => Your::Own::Auth::Module->new(...), loop => Event::RPC::Loop::Event->new(), host => "localhost", load_modules => 1, auto_reload_modules => 1, connection_hook => sub { ... }, message_formats => [qw/ SERL CBOR JSON STOR /], insecure_msg_fmt_ok => 1, ); $server->set_max_packet_size(2*1024*1024*1024); # start server and event loop $server->start; # or prepare server start if you like to control event loop by yourself $server->prepare; # and later from inside your server implementation Event::RPC::Server->instance->stop; =head1 DESCRIPTION Use this module to add a simple to use RPC mechanism to your event driven server application. Just create an instance of the Event::RPC::Server class with a bunch of required settings. Then enter the main event loop through it, or take control over the main loop on your own if you like (refer to the MAINLOOP chapter for details). General information about the architecture of Event::RPC driven applications is collected in the Event::RPC manpage. =head1 CONFIGURATION OPTIONS All options described here may be passed to the new() constructor of Event::RPC::Server. As well you may set or modify them using set_OPTION style mutators, but not after start() or setup_listeners() was called! All options may be read using get_OPTION style accessors. =head2 REQUIRED OPTIONS If you just pass the required options listed beyond you have a RPC server which listens to a network port and allows everyone connecting to it to access a well defined list of classes and methods resp. using the correspondent server objects. There is no authentication or encryption active in this minimal configuration, so aware that this may be a big security risk! Adding security is easy, refer to the chapters about SSL and authentication. These are the required options: =over 4 =item B TCP port number of the RPC listener. =item B This is a hash ref with the following structure: classes => { "Class1" => { new => "_constructor", simple_method => 1, object_returner => "_object", }, "Class2" => { ... }, ... }, Each class which should be accessible for clients needs to be listed here at the first level, assigned a hash of methods allowed to be called. Event::RPC disuinguishes three types of methods by classifying their return value: =over 4 =item B A constructor method creates a new object of the corresponding class and returns it. You need to assign the string "_constructor" to the method entry to mark a method as a constructor. =item B For singleton classes the method which returns the singleton instance should be declared with "_singleton". This way the server takes care that references get never destroyed on server side. =item B What's simple about these methods is their return value: it's a scalar, array, hash or even any complex reference structure (Ok, not simple anymore ;), but in particular it returns B objects, because this needs to handled specially (see below). Declare simple methods by assigning 1 in the method declaration. =item B Methods which return objects need to be declared by assigning "_object" to the method name here. They're not bound to return just one scalar object reference and may return an array or list reference with a bunch of objects as well. =back =back =head2 SSL OPTIONS The client/server protocol of Event::RPC is not encrypted by default, so everyone listening on your network can read or even manipulate data. To prevent this efficiently you can enable SSL encryption. Event::RPC uses the IO::Socket::SSL Perl module for this. First you need to generate a server key and certificate for your server using the openssl command which is part of the OpenSSL distribution, e.g. by issueing these commands (please refer to the manpage of openssl for details - this is a very rough example, which works in general, but probably you want to tweak some parameters): % openssl genrsa -des3 -out server.key 1024 % openssl req -new -key server.key -out server.csr % openssl x509 -req -days 3600 -in server.csr \ -signkey server.key -out server.crt After executing these commands you have the following files server.crt server.key server.csr Event::RPC needs the first two of them to operate with SSL encryption. To enable SSL encryption you need to pass the following options to the constructor: =over 4 =item B The ssl option needs to be set to 1. =item B This is the filename of the server.key you generated with the openssl command. =item B This is the filename of the server.crt file you generated with the openssl command. =item B Your server key is encrypted with a password you entered during the key creation process described above. This callback must return it. Depending on how critical your application is you probably must request the password from the user during server startup or place it into a more or less secured file. For testing purposes you can specify a simple anonymous sub here, which just returns the password, e.g. ssl_passwd_cb => sub { return "topsecret" } But note: having the password in plaintext in your program code is insecure! =item B This optional parameter takes a hash reference of options passed to IO::Socket::SSL->new(...) to have more control over the server SSL listener. =back =head2 AUTHENTICATION OPTIONS SSL encryption is fine, now it's really hard for an attacker to listen or modify your network communication. But without any further configuration any user on your network is able to connect to your server. To prevent this users resp. connections to your server needs to be authenticated somehow. Since version 0.87 Event::RPC has an API to delegate authentication tasks to a module, which can be implemented outside Event::RPC. To be compatible with prior releases it ships the module Event::RPC::AuthPasswdHash which implements the old behaviour transparently. This default implementation is a simple user/password based model. For now this controls just the right to connect to your server, so knowing one valid user/password pair is enough to access all exported methods of your server. Probably a more differentiated model will be added later which allows granting access to a subset of exported methods only for each user who is allowed to connect. The following options control the authentication: =over 4 =item B Set this to 1 to enable authentication and nobody can connect your server until he passes a valid user/password pair. =item B If you like to use the builtin Event::RPC::AuthPasswdHash module simply set this attribute. If you decide to use B (explained beyound) it's not necessary. B is a hash of valid user/password pairs. The password stored here needs to be encrypted using Perl's crypt() function, using the username as the salt. Event::RPC has a convenience function for generating such a crypted password, although it's currently just a 1:1 wrapper around Perl's builtin crypt() function, but probably this changes someday, so better use this method: $crypted_pass = Event::RPC->crypt($user, $pass); This is a simple example of setting up a proper B with two users: auth_passwd_href => { fred => Event::RPC->crypt("fred", $freds_password), nick => Event::RPC->crypt("nick", $nicks_password), }, =item B If you like to implement a more complex authentication method yourself you may set the B attribute to an instance of your class. For now your implementation just needs to have this method: $auth_module->check_credentials($user, $pass) Aware that $pass is encrypted as explained above, so your original password needs to by crypted using Event::RPC->crypt as well, at least for the comparison itself. =back B you can use the authentication module without SSL but aware that an attacker listening to the network connection will be able to grab the encrypted password token and authenticate himself with it to the server (replay attack). Probably a more sophisticated challenge/response mechanism will be added to Event::RPC to prevent this. But you definitely should use SSL encryption in a critical environment anyway, which renders grabbing the password from the net impossible. =head2 LOGGING OPTIONS Event::RPC has some logging abilities, primarily for debugging purposes. It uses a B for this, which is an object implementing the Event::RPC::Logger interface. The documentation of Event::RPC::Logger describes this interface and Event::RPC's logging facilities in general. =over 4 =item B To enable logging just pass such an Event::RPC::Logger object to the constructor. =item B Additionally Event::RPC can start a log listener on the server's port number incremented by 1. All clients connected to this port (e.g. by using telnet) get the server's log output. Note: currently the logging port supports neither SSL nor authentication, so be careful enabling the log listener in critical environments. =back =head2 MAINLOOP OPTIONS Event::RPC derived it's name from the fact that it follows the event driven paradigm. There are several toolkits for Perl which allow event driven software development. Event::RPC has an abstraction layer for this and thus should be able to work with any toolkit. =over 4 =item B This option takes an object of the loop abstraction layer you want to use. Currently the following modules are implemented: Event::RPC::Loop::AnyEvent Use the AnyEvent module Event::RPC::Loop::Event Use the Event module Event::RPC::Loop::Glib Use the Glib module If B isn't set, Event::RPC::Server tries all supported modules in a row and aborts the program, if no module was found. More modules will be added in the future. If you want to implement one just take a look at the code in the modules above: it's really easy and I appreciate your patch. The interface is roughly described in the documentation of Event::RPC::Loop. =back If you use the Event::RPC->start() method as described in the SYNOPSIS Event::RPC will enter the correspondent main loop for you. If you want to have full control over the main loop, use this method to setup all necessary Event::RPC listeners: $rpc_server->setup_listeners(); and manage the main loop stuff on your own. =head2 MESSAGE FORMAT OPTIONS Event::RPC supports different CPAN modules for data serialisation, named "message formats" here: SERL -- Sereal::Encoder, Sereal::Decoder CBOR -- CBOR::XS JSON -- JSON::XS STOR -- Storable Server and client negotiate automatically which format is best to use but you can manipulate this behaviour with the following options: =over 4 =item B This takes an array of format identifiers from the list above. Event::RPC::Server will only use / accept these formats. =item B The Storable module is known to be insecure. But for backward compatibility reasons Event::RPC::Server accepts clients which can't offer anything but Storable. You can prevent that by setting this option explicitely to 0. It's enabled by default. =back =head2 MISCELLANEOUS OPTIONS =over 4 =item B By default the network listeners are bound to all interfaces in the system. Use the host option to bind to a specific interface, e.g. "localhost" if you efficiently want to prevent network clients from accessing your server. =item B Control whether the class module files should be loaded automatically when first accesed by a client. This options defaults to true, for backward compatibility reasons. =item B If this option is set Event::RPC::Server will check on each method call if the corresponding module changed on disk and reloads it automatically. Of course this has an effect on performance, but it's very useful during development. You probably shouldn't enable this in production environments. =item B This callback is called on each connection / disconnection with two arguments: the Event::RPC::Connection object and a string containing either "connect" or "disconnect" depending what's currently happening with this connection. =back =head1 METHODS The following methods are publically available: =over 4 =item Event::RPC::Server->B This returns the latest created Event::RPC::Server instance (usually you have only one instance in one program). =item $rpc_server->B Start the mainloop of your Event::RPC::Server. =item $rpc_server->B Stops the mainloop which usually means, that the server exits, as long you don't do more sophisticated mainloop stuff by your own. =item $rpc_server->B This method initializes all networking listeners needed for Event::RPC::Server to work, using the configured loop module. Use this method if you don't use the start() method but manage the mainloop on your own. =item $rpc_server->B ( [$level,] $msg ) Convenience method for logging. It simply passes the arguments to the configured logger's log() method. =item $rpc_server->B Returns the number of currently connected Event::RPC clients. =item $rpc_server->B Returns the number of currently connected logging clients. =item $rpc_server->B This returns the currently active Event::RPC::Connection object representing the connection resp. the client which currently requests method invocation. This is undef if no client call is active. =item $rpc_client->B ( $bytes ) By default Event::RPC does not handle network packages which exceed 2 GB in size (was 4 MB with version 1.04 and earlier). You can change this value using this method at any time, but 4 GB is the maximum. An attempt of the server to send a bigger packet will be aborted and reported as an exception on the client and logged as an error message on the server. Note: you have to set the same value on client and server side! =item $rpc_client->B Returns the currently active max packet size. =back =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Loop.pm0000644000175000017500000000726012601723500015675 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Loop; use strict; use utf8; sub new { my $class = shift; return bless {}, $class; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Loop - Mainloop Abstraction layer for Event::RPC =head1 SYNOPSIS use Event::RPC::Server; use Event::RPC::Loop::Glib; my $server = Event::RPC::Server->new ( ... loop => Event::RPC::Loop::Glib->new(), ... ); $server->start; =head1 DESCRIPTION This modules defines the interface of Event::RPC's mainloop abstraction layer. It's a virtual class all mainloop modules should inherit from. =head1 INTERFACE The following methods need to be implemented: =over 4 =item $loop->B () Enter resp. start a mainloop. =item $loop->B () Leave the mainloop, which was started with the enter() method. =item $watcher = $loop->B ( %options ) Add an I/O watcher. Options are passed as a hash of key/value pairs. The following options are known: =over 4 =item B The filehandle to be watched. =item B This callback is called, without any parameters, if an event occured on the filehandle above. =item B A description of the watcher. Not necessarily implemented by all modules, so it may be ignored. =item B Either 'r', if your program reads from the filehandle, or 'w' if it writes to it. =back A watcher object is returned. What this exactly is depends on the implementation, so you can't do anything useful with it besides passing it back to del_io_watcher(). =item $loop->B ( $watcher ) Deletes an I/O watcher which was added with $loop->add_io_watcher(). =item $timer = $loop->B ( %options ) This sets a timer, a subroutine called after a specific timeout or on a regularly basis with a fixed time interval. Options are passed as a hash of key/value pairs. The following options are known: =over 4 =item B A time interval in seconds, may be fractional. =item B Callback is called once after this amount of seconds, may be fractional. =item B The callback. =item B A description of the timer. Not necessarily implemented by all modules, so it may be ignored. =back A timer object is returned. What this exactly is depends on the implementation, so you can't do anything useful with it besides passing it back to del_io_timer(). =item $loop->B ( $timer ) Deletes a timer which was added with $loop->add_timer(). =back =head1 DIRECT USAGE IN YOUR SERVER You may use the methods of Event::RPC::Loop by yourself if you like. This way your program keeps independent of the actual mainloop module in use, if the simplified interface of Event::RPC::Loop is sufficient for you. In your server program you access the actual mainloop object this way: my $loop = Event::RPC::Server->instance->get_loop; Naturally nothing speaks against making your program to work only with a specific mainloop implementation, if you need its features. In that case you may use the corresponding API directly (e.g. of Event or Glib), no need to access it through Event::RPC::Loop. =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/Client.pm0000644000175000017500000006374712601723500016216 0ustar joernjoern#----------------------------------------------------------------------- # Copyright (C) 2005-2015 by Jörn Reder . # All Rights Reserved. See file COPYRIGHT for details. # # This module is part of Event::RPC, which is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. #----------------------------------------------------------------------- package Event::RPC::Client; use Event::RPC; use Event::RPC::Message::Negotiate; use Carp; use strict; use utf8; use IO::Socket::INET; #-- This can be changed for testing purposes e.g. to simulate #-- old clients connecting straight with Storable format. $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Negotiate"; sub get_client_version { $Event::RPC::VERSION } sub get_client_protocol { $Event::RPC::PROTOCOL } sub get_host { shift->{host} } sub get_port { shift->{port} } sub get_sock { shift->{sock} } sub get_timeout { shift->{timeout} } sub get_classes { shift->{classes} } sub get_class_map { shift->{class_map} } sub get_loaded_classes { shift->{loaded_classes} } sub get_error_cb { shift->{error_cb} } sub get_ssl { shift->{ssl} } sub get_ssl_ca_file { shift->{ssl_ca_file} } sub get_ssl_ca_path { shift->{ssl_ca_path} } sub get_ssl_opts { shift->{ssl_opts} } sub get_auth_user { shift->{auth_user} } sub get_auth_pass { shift->{auth_pass} } sub get_connected { shift->{connected} } sub get_server { shift->{server} } sub get_server_version { shift->{server_version} } sub get_server_protocol { shift->{server_protocol} } sub get_message_format { shift->{message_format} } sub get_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} } sub set_host { shift->{host} = $_[1] } sub set_port { shift->{port} = $_[1] } sub set_sock { shift->{sock} = $_[1] } sub set_timeout { shift->{timeout} = $_[1] } sub set_classes { shift->{classes} = $_[1] } sub set_class_map { shift->{class_map} = $_[1] } sub set_loaded_classes { shift->{loaded_classes} = $_[1] } sub set_error_cb { shift->{error_cb} = $_[1] } sub set_ssl { shift->{ssl} = $_[1] } sub set_ssl_ca_file { shift->{ssl_ca_file} = $_[1] } sub set_ssl_ca_path { shift->{ssl_ca_path} = $_[1] } sub set_ssl_opts { shift->{ssl_opts} = $_[1] } sub set_auth_user { shift->{auth_user} = $_[1] } sub set_auth_pass { shift->{auth_pass} = $_[1] } sub set_connected { shift->{connected} = $_[1] } sub set_server { shift->{server} = $_[1] } sub set_server_version { shift->{server_version} = $_[1] } sub set_server_protocol { shift->{server_protocol} = $_[1] } sub set_message_format { shift->{message_format} = $_[1] } sub set_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} = $_[1] } sub get_max_packet_size { return Event::RPC::Message->get_max_packet_size; } sub set_max_packet_size { my $class = shift; my ($value) = @_; Event::RPC::Message->set_max_packet_size($value); } sub new { my $class = shift; my %par = @_; my ($server, $host, $port, $classes, $class_map, $error_cb, $timeout) = @par{'server','host','port','classes','class_map','error_cb','timeout'}; my ($ssl, $ssl_ca_file, $ssl_opts, $auth_user, $auth_pass, $insecure_msg_fmt_ok) = @par{'ssl','ssl_ca_file','ssl_opts','auth_user','auth_pass','insecure_msg_fmt_ok'}; $server ||= ''; $host ||= ''; $insecure_msg_fmt_ok = 1 unless defined $insecure_msg_fmt_ok; if ( $server ne '' and $host eq '' ) { warn "Option 'server' is deprecated. Use 'host' instead."; $host = $server; } my $self = bless { host => $server, server => $host, port => $port, timeout => $timeout, classes => $classes, class_map => $class_map, ssl => $ssl, ssl_ca_file => $ssl_ca_file, ssl_opts => $ssl_opts, auth_user => $auth_user, auth_pass => $auth_pass, error_cb => $error_cb, message_format => $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT, insecure_msg_fmt_ok => $insecure_msg_fmt_ok, loaded_classes => {}, connected => 0, }, $class; return $self; } sub connect { my $self = shift; croak "Client is already connected" if $self->get_connected; my $ssl = $self->get_ssl; my $server = $self->get_server; my $port = $self->get_port; my $timeout = $self->get_timeout; $self->set_message_format($Event::RPC::Client::DEFAULT_MESSAGE_FORMAT); #-- Client may try to fallback to Storable Event::RPC::Message::Negotiate->set_storable_fallback_ok(1) if $self->get_message_format eq 'Event::RPC::Message::Negotiate' and $self->get_insecure_msg_fmt_ok; if ( $ssl ) { eval { require IO::Socket::SSL }; croak "SSL requested, but IO::Socket::SSL not installed" if $@; } my $sock; if ( $ssl ) { my @verify_opts; if ( $self->get_ssl_ca_file or $self->get_ssl_ca_path ) { push @verify_opts, ( SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(), SSL_ca_file => $self->get_ssl_ca_file, SSL_ca_path => $self->get_ssl_ca_path, ); } else { push @verify_opts, ( SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(), ); } my $ssl_opts = $self->get_ssl_opts; $sock = IO::Socket::SSL->new( Proto => 'tcp', PeerPort => $port, PeerAddr => $server, Type => SOCK_STREAM, Timeout => $timeout, @verify_opts, ($ssl_opts?%{$ssl_opts}:()), ) or croak "Can't open SSL connection to $server:$port: $IO::Socket::SSL::ERROR"; } else { $sock = IO::Socket::INET->new( Proto => 'tcp', PeerPort => $port, PeerAddr => $server, Type => SOCK_STREAM, Timeout => $timeout, ) or croak "Can't open connection to $server:$port - $!"; } $sock->autoflush(1); $self->set_sock($sock); eval { #-- Perform message format negotitation if we are not #-- configured to a specific format already. $self->negotiate_message_format if $self->get_message_format eq 'Event::RPC::Message::Negotiate'; $self->check_version; }; if ( $@ ) { $self->disconnect; die $@; } my $auth_user = $self->get_auth_user; my $auth_pass = $self->get_auth_pass; if ( $auth_user ) { my $rc = $self->send_request( { cmd => 'auth', user => $auth_user, pass => $auth_pass, } ); if ( not $rc->{ok} ) { $self->disconnect; croak $rc->{msg}; } } if ( not $self->get_classes ) { $self->load_all_classes; } else { $self->load_classes; } $self->set_connected(1); 1; } sub log_connect { my $class = shift; my %par = @_; my ( $server, $port ) = @par{ 'server', 'port' }; my $sock = IO::Socket::INET->new( Proto => 'tcp', PeerPort => $port, PeerAddr => $server, Type => SOCK_STREAM ) or croak "Can't open connection to $server:$port - $!"; return $sock; } sub disconnect { my $self = shift; close( $self->get_sock ) if $self->get_sock; $self->set_connected(0); 1; } sub DESTROY { shift->disconnect; } sub error { my $self = shift; my ($message) = @_; my $error_cb = $self->get_error_cb; if ($error_cb) { &$error_cb( $self, $message ); } else { die "Unhandled error in client/server communication: $message"; } 1; } sub negotiate_message_format { my $self = shift; my $rc = eval { $self->send_request({ cmd => "neg_formats_avail" }) }; if ( $@ ) { #-- On error we probably may fall back to Storable #-- (we connected to an old server) if ( $self->get_insecure_msg_fmt_ok ) { require Event::RPC::Message::Storable; $self->set_message_format("Event::RPC::Message::Storable"); return; } #-- die if Storable is not allowed die "Error on message format negotiation and client is not ". "allowed to fall back to Storable\n"; } my $modules_by_format_name = Event::RPC::Message::Negotiate->known_message_formats; my @formats = split(/,/, $rc->{msg}); my $format_chosen = ''; my $module_chosen = ''; foreach my $format ( @formats ) { my $module = $modules_by_format_name->{$format} or die "Unknown message format '$format"; eval "use $module"; if ( not $@ ) { $format_chosen = $format; $module_chosen = $module; last; }; } die "Can't negotiate message format\n" unless $format_chosen; eval { $self->send_request({ cmd => "neg_format_set", msg => $format_chosen, }) }; die "Error on neg_format_set: $@" if $@; $self->set_message_format($module_chosen); 1; } sub check_version { my $self = shift; my $rc = eval { $self->send_request( { cmd => 'version', } ) }; die "CATCHED $@" if $@; $self->set_server_version( $rc->{version} ); $self->set_server_protocol( $rc->{protocol} ); if ( $rc->{version} ne $self->get_client_version ) { warn "Event::RPC warning: server version $rc->{version} != " . "client version " . $self->get_client_version; } if ( $rc->{protocol} < $self->get_client_protocol ) { die "FATAL: Server protocol version $rc->{protocol} < " . "client protocol version " . $self->get_client_protocol; } 1; } sub load_all_classes { my $self = shift; my $rc = $self->send_request( { cmd => 'class_info_all', } ); my $class_info_all = $rc->{class_info_all}; foreach my $class ( keys %{$class_info_all} ) { $self->load_class( $class, $class_info_all->{$class} ); } 1; } sub load_classes { my $self = shift; my $classes = $self->get_classes; my %classes; @classes{ @{$classes} } = (1) x @{$classes}; my $rc = $self->send_request( { cmd => 'classes_list', } ); foreach my $class ( @{ $rc->{classes} } ) { next if not $classes{$class}; $classes{$class} = 0; my $rc = $self->send_request( { cmd => 'class_info', class => $class, } ); $self->load_class( $class, $rc->{methods} ); } foreach my $class ( @{$classes} ) { warn "WARNING: Class '$class' not exported by server" if $classes{$class}; } 1; } sub load_class { my $self = shift; my ( $class, $methods ) = @_; my $loaded_classes = $self->get_loaded_classes; return 1 if $loaded_classes->{$class}; $loaded_classes->{$class} = 1; my $local_method; my $class_map = $self->get_class_map; my $local_class = $class_map->{$class} || $class; # create local destructor for this class { no strict 'refs'; my $local_method = $local_class . '::' . "DESTROY"; *$local_method = sub { return if not $self->get_connected; my $oid_ref = shift; $self->send_request({ cmd => "client_destroy", oid => ${$oid_ref}, }); }; } # create local methods for this class foreach my $method ( keys %{$methods} ) { $local_method = $local_class . '::' . $method; my $method_type = $methods->{$method}; if ( $method_type eq '_constructor' ) { # this is a constructor for this class my $request_method = $class . '::' . $method; no strict 'refs'; *$local_method = sub { shift; my $rc = $self->send_request({ cmd => 'new', method => $request_method, params => \@_, }); my $oid = $rc->{oid}; return bless \$oid, $local_class; }; } elsif ( $method_type eq '1' ) { # this is a simple method my $request_method = $method; no strict 'refs'; *$local_method = sub { my $oid_ref = shift; my $rc = $self->send_request({ cmd => 'exec', oid => ${$oid_ref}, method => $request_method, params => \@_, }); return unless $rc; $rc = $rc->{rc}; return @{$rc} if wantarray; return $rc->[0]; }; } else { # this is a object returner my $request_method = $method; no strict 'refs'; *$local_method = sub { my $oid_ref = shift; my $rc = $self->send_request({ cmd => 'exec', oid => ${$oid_ref}, method => $request_method, params => \@_, }); return unless $rc; $rc = $rc->{rc}; foreach my $val ( @{$rc} ) { if ( ref $val eq 'ARRAY' ) { foreach my $list_elem ( @{$val} ) { my ($class) = split( "=", "$list_elem", 2 ); $self->load_class($class) unless $loaded_classes->{$class}; my $list_elem_copy = $list_elem; $list_elem = \$list_elem_copy; bless $list_elem, ( $class_map->{$class} || $class ); } } elsif ( ref $val eq 'HASH' ) { foreach my $hash_elem ( values %{$val} ) { my ($class) = split( "=", "$hash_elem", 2 ); $self->load_class($class) unless $loaded_classes->{$class}; my $hash_elem_copy = $hash_elem; $hash_elem = \$hash_elem_copy; bless $hash_elem, ( $class_map->{$class} || $class ); } } elsif ( defined $val ) { my ($class) = split( "=", "$val", 2 ); $self->load_class($class) unless $loaded_classes->{$class}; my $val_copy = $val; $val = \$val_copy; bless $val, ( $class_map->{$class} || $class ); } } return @{$rc} if wantarray; return $rc->[0]; }; } } return $local_class; } sub send_request { my $self = shift; my ($request) = @_; my $message = $self->get_message_format->new( $self->get_sock ); $message->write_blocked($request); my $rc = eval { $message->read_blocked }; if ($@) { $self->error($@); return; } if ( not $rc->{ok} ) { $rc->{msg} .= "\n" if not $rc->{msg} =~ /\n$/; croak ("$rc->{msg} -- called via Event::RPC::Client"); } return $rc; } 1; __END__ =encoding utf8 =head1 NAME Event::RPC::Client - Client API to connect to Event::RPC Servers =head1 SYNOPSIS use Event::RPC::Client; my $rpc_client = Event::RPC::Client->new ( #-- Required arguments host => "localhost", port => 5555, #-- Optional arguments classes => [ "Event::RPC::Test" ], class_map => { "Event::RPC::Test" => "My::Event::RPC::Test" }, ssl => 1, ssl_ca_file => "some/ca.crt", ssl_ca_path => "some/ca/dir", ssl_opts => { SSL_verifycn_name => 'server-hostname' }, timeout => 10, auth_user => "fred", auth_pass => Event::RPC->crypt("fred",$password), insecure_msg_fmt_ok => 1, error_cb => sub { my ($client, $error) = @_; print "An RPC error occured: $error\n"; $client->disconnect; exit; }, ); $rpc_client->set_max_packet_size(2*1024*1024*1024); $rpc_client->connect; #-- And now use classes and methods to which the #-- server allows access via RPC, here My::TestModule #-- from the Event::RPC::Server manpage SYNPOSIS. my $obj = My::TestModule->new( data => "foobar" ); print "obj says hello: ".$obj->hello."\n"; $obj->set_data("new foobar"); print "updated data: ".$obj->get_data."\n"; $rpc_client->disconnect; =head1 DESCRIPTION Use this module to write clients accessing objects and methods exported by a Event::RPC driven server. Just connect to the server over the network, optionally with SSL and user authentication, and then simply use the exported classes and methods like having them locally in the client. General information about the architecture of Event::RPC driven applications is collected in the Event::RPC manpage. The following documentation describes the client connection options in detail. =head1 CONFIGURATION OPTIONS You need to specify at least the server hostname and TCP port to connect a Event::RPC server instance. If the server requires a SSL connection or user authentication you need to supply the corresponding options as well, otherwise connecting will fail. All options described here may be passed to the new() constructor of Event::RPC::Client. As well you may set or modify them using set_OPTION style mutators, but not after connect() was called! All options may be read using get_OPTION style accessors. =head2 REQUIRED OPTIONS These are necessary to connect the server: =over 4 =item B This is the hostname of the server running Event::RPC::Server. Use a IP address or DNS name here. =item B This is the TCP port the server is listening to. =back =head2 NETWORK OPTIONS =over 4 =item B Specify a timeout (in seconds), which is applied when connecting the server. =back =head2 CLASS IMPORT OPTION =over 4 =item B This is reference to a list of classes which should be imported into the client. You get a warning if you request a class which is not exported by the server. By default all server classes are imported. Use this feature if your server exports a huge list of classes, but your client doesn't need all of them. This saves memory in the client and connect performance increases. =item B Optionally you can map the class names from the server to a different name on the local client using the B hash. This is necessary if you like to use the same classes locally and remotely. Imported classes from the server are by default registered under the same name on the client, so this conflicts with local classes named identically. On the client you access the remote classes under the name assigned in the class map. For example with this map class_map => { "Event::ExecFlow::Job" => "_srv::Event::ExecFlow::Job" } you need to write this on the client, if you like to create an object remotely on the server: my $server_job = _srv::Event::ExecFlow::Job->new ( ... ); and this to create an object on the client: my $client_job = Event::ExecFlow::Job->new ( ... ); The server knows nothing of the renaming on client side, so you still write this on the server to create objects there: my $job = Event::ExecFlow::Job->new ( ... ); =back =head2 SSL OPTIONS If the server accepts only SSL connections you need to enable ssl here in the client as well. By default the SSL connection will be established without any peer verification, which makes Man-in-the-Middle attacks possible. If you want to prevent that, you need to set either B or B option. =over 4 =item B Set this option to 1 to encrypt the network connection using SSL. =item B Path to the the Certificate Authority's certificate file (ca.crt), your server key was signed with. =item B Path of a directory containing several trusted certificates with a proper index. Please refer to the OpenSSL documentation for details about setting up such a directory. =item B This optional parameter takes a hash reference of options passed to IO::Socket::SSL->new(...) to have more control over the SSL connection. For example you can set the 'SSL_verifycn_name' here if the server certificate common name doesn't match to the hostname you use to resolve the server IP or use you have to use a static server IP address or something like that. =back =head2 AUTHENTICATION OPTIONS If the server requires user authentication you need to set the following options: =over 4 =item B A valid username. =item B The corresponding password, encrypted using Perl's crypt() function, using the username as the salt. Event::RPC has a convenience function for generating such a crypted password, although it's currently just a wrapper around Perl's builtin crypt() function, but probably this changes someday, so better use this method: $crypted_pass = Event::RPC->crypt($user, $pass); =back If the passed credentials are invalid the Event::RPC::Client->connect() method throws a correspondent exception. =head2 MESSAGE FORMAT OPTIONS Event::RPC supports different CPAN modules for data serialisation, named "message formats" here: SERL -- Sereal::Encoder, Sereal::Decoder CBOR -- CBOR::XS JSON -- JSON::XS STOR -- Storable Server and client negotiate automatically which format is best to use. The server sends a list of supported formats to the client which takes the first one which is available. For the client there is one option to influence this format negotiation mechanism: =over 4 =item B The Storable module is known to be insecure, so it should be taken as the last option only. By default the Client would do so. You can prevent that by setting this option explicitely to 0. It's enabled by default. Most likely the connection will fail in that case, because the server only will offer Storable if no other serialiser is available. =back =head2 ERROR HANDLING Any exceptions thrown on the server during execution of a remote method will result in a corresponding exception on the client. So you can use normal exception handling with eval {} when executing remote methods. But besides this the network connection between your client and the server may break at any time. This raises an exception as well, but you can override this behaviour with the following attribute: =over 4 =item B This subroutine is called if any error occurs in the network communication between the client and the server. The actual Event::RPC::Client object and an error string are passed as arguments. This is B generic exception handler for exceptions thrown from the executed methods on the server! If you like to catch such exceptions you need to put an eval {} around your method calls, as you would do for local method calls. If you don't specify an B an exception is thrown instead. =back =head1 METHODS =over 4 =item $rpc_client->B This establishes the configured connection to the server. An exception is thrown if something goes wrong, e.g. server not available, credentials are invalid or something like this. =item $rpc_client->B Closes the connection to the server. You may omit explicit disconnecting since it's done automatically once the Event::RPC::Client object gets destroyed. =item $rpc_client->B ( $bytes ) By default Event::RPC does not handle network packages which exceed 2 GB in size (was 4 MB with version 1.04 and earlier). You can change this value using this method at any time, but 4 GB is the maximum. An attempt of the server to send a bigger packet will be aborted and reported as an exception on the client and logged as an error message on the server. Note: you have to set the same value on client and server side! =item $rpc_client->B Returns the currently active max packet size. =back =head1 READY ONLY ATTRIBUTES =over 4 =item $rpc_client->B Returns the Event::RPC version number of the server after connecting. =item $rpc_client->B Returns the Event::RPC protocol number of the server after connecting. =item $rpc_client->B Returns the Event::RPC version number of the client. =item $rpc_client->B Returns the Event::RPC protocol number of the client. =back =head1 AUTHORS Jörn Reder =head1 COPYRIGHT AND LICENSE Copyright (C) 2005-2015 by Jörn Reder . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Event-RPC-1.10/lib/Event/RPC/AuthPasswdHash.pm0000644000175000017500000000076110351260040017645 0ustar joernjoernpackage Event::RPC::AuthPasswdHash; use strict; use Carp; sub get_passwd_href { shift->{passwd_href} } sub set_passwd_href { shift->{passwd_href} = $_[1] } sub new { my $class = shift; my ($passwd_href) = @_; my $self = bless { passwd_href => $passwd_href, }; return $self; } sub check_credentials { my $self = shift; my ($user, $pass) = @_; return $pass eq $self->get_passwd_href->{$user}; } 1;