Net-DBus-1.0.0/0000755000076500007650000000000011603165554013245 5ustar berrangeberrangeNet-DBus-1.0.0/CHANGES0000644000076500007650000002115411603165524014240 0ustar berrangeberrange New in 1.0.0: - Updated to require minimum dbus >= 1.0.0 - Automatically track change in ownership of bus names for signal handlers - Strict validation of method invocation against introspection data on exported objects - Improved error messages for invalid interfaces - Add API for disconnecting an object from a signal - Implement GetAll methods on properties interface - Allow leading _ in interface names - Other minor fixes Changes since 0.33.5 - Fix introspection XML handling when exporting objects with child objects - Improve output of Net::DBus::Dumper - Add support for providing parameter & return value names in introspection XML - Fixes to marshalling of variants - Fix handling of compound data types within object properties - Remove non-portable makefile rules - Fix ref counting bugs in error path. Changes since 0.33.4 - Added support for getting private bus connections for apps which don't want to deal with a shared bus - Fix test case to use a private connection - On Perl builds where integers are 32-bits, the DBus 64 bit integer types will be serialized to/from the Perl String type instead of calling 'die'. - Fix signature when marshalling dicts on newer DBus builds - Fix calling of disconnect wrt to newer DBus semantics - Make introspection much more tolerant of missing information about methods/properties/signals. - Fix use of magic values & added tests - Export the Net::DBus::Dumper methods correctly. Changes since 0.33.3 - Fixed service owner used for org.freedesktop.DBus object to make signal handling on the bus work again - Pass return value for signal handling callbacks all the way back to DBus - Fix multiple problems with marshalling of variant data types - Replace use of dbus_connection_disconnect with _close when compiling against dbus >= 0.90 - Call dbus_connection_unref in the DESTROY method of connection object - Fix reference counting in connection & pending call objects - Added example of galago desktop notifications - Fix test suite errors - Added missing import statement - Throw Net::DBus::Error if an async call fails Changes since 0.33.2 - Fixed parsing of introspection data if there are processing instructions, or other non-data nodes before the root element. - Replace use of XML::Grove with XML::Twig when parsing the introspection XML documents, since the former has not had any updates / bug fixes since 1999(!), and several people have reported problems using it on Perl 5.8.x - Made all Perl scripts / modules / tests use 'strict' and 'warnings' pragmas - Turn Net::DBus::Error into fully fledged object which services can sub-class to allow explicit error handling by clients. - In _dispatch method of Net::DBus::Object ensure that any instances of Net::DBus::Error thrown by the method call are explicitly serialized into DBus errors, rather than a generic 'org.freedesktop.DBus.Failed'. - Change re-distribution license from GPL, to GPL / Perl Artistic, matching the terms of Perl itself. - Add support for registering a callback on Net::DBus::ASyncReply objects to allow notification of completion for asynchronous method calls Changes since 0.33.1 - Fixed handling of variants in introspection data - Added binding for the DBusPendingCall C object - Added some missing RPM dependancies on XML libs, and on minimum required dbus version - Added support for doing asynchronous method calls, and fire-and- forgot calls for methods whose return status is not desired. Use the constants in Net::DBus::Annotation module to indicate desired call mode. Default is to do synchronous blocking calls. - Added support for the 16-bit integer, signature and object path data types - Made introspection of root objects compliant with upsteam spec, by calling introspect on the root object, "/", rather than a Perl specific magic object path. Changes since 0.32.3 - Constructor for Net::DBus::Object allows another Net::DBus::Object to be passed instead of the Net::DBus::Service, to create child objects specifying only a relative path. - Updated minimum required DBus version to be 0.33 to gain access to the unregister_object_path API - Add a disconnect() method to Net::DBus::Object to make it possible to unregister object from the bus & thus make it possible to destroy objects which are no longer required / relevant. - Unregister all child objects if we are unregistered ourselves - Fix numerous POD errors identified by Test::Pod and podchecker - Increase POD documentation to get 100% coverage of all APIs, verified by Test::Pod::Coverage Changes since 0.32.2 - Introspection data is used only as hint, so if an object exports many methods, but only provides partial introspection data, remote calls fallback to regular typing rules - Re-add dbus_XXX convenience methods to Net::DBus to allow clients to do explicit type casting. Must be requested at export time, using 'Net::DBus qw(:typing)'. - Update all example programs to run against session bus, since there are no security rules to enable them to work on system bus. - Print out warning upon use, if a method, signal, or property is annotated with the 'org.freedesktop.DBus.Deprecated' flag. - Do not wait for a method reply if the method is annotated with the 'org.freedesktop.DBus.Method.NoReply' flag. - Extend Net::DBus::Exporter to enable methods, signals, and properties to be annotated. - Add support for 'org.freedesktop.DBus.Method.NoReply' and 'org.freedesktop.DBus.Deprecated' annotations when exporting objects - Add a pure in-memory bus implementation for facilitating creation of unit tests which would otherwise require making a connection to a 'live' message bus. Can be accessed via: Net::DBus->test - Add an *EXPERIMENTAL* mock object to faciltate creation of unit tests which need to communicate with other objects on the bus. See Net::DBus::Test::MockObject for further info. Changes since 0.32.1 - Fix unit tests broken in previous build - Added patch to avoid leaking memory when throwing dbus errors from the XS layer - Added support for org.freedesktop.DBus.Properties in exported & remote objects. - Added support for getting the unique name of the client's connection to the bus - Added support for getting the unique name of the client owning a service on the bus - RemoteService object constructor gains an extra parameter for the owner of the service at the time it was aquired to deal with issues where a service is replaced. - Cache RemoteService objects to avoid creating multiple instances for the same service name. - Fix caching of objects by the service to avoid caching objects cast to a specific interface - Make add_signal_receiver method on Net::DBus private - Use introspection data for hinting only, not absolute truth since Python bindings don't provide complete data. - Adding correct handling for (de)marshalling variant data type to fix interaction with python bindings - Added magic 'caller' and 'serial' data types for requesting that data about method caller be passed into a method - Lots more POD documentation - Added 'lshal.pl' demo script for listing HAL devices - Made example scripts interoperate correctly with example scripts from Python & GLib bindings Changes since 0.32.0 - The order of 'service_name' and 'bus' parameter to the Net::DBus::Service constructor is reversed to match that of Net::DBus::RemoteService - The order of 'service' and 'object_path' parameter to the Net::DBus::Object constructor is reversed to match that of Net::DBus::RemoteObject - No longer neccessary to construct an explicit Net::DBus::Service object - one is constructed & returned by the 'export_service' method on Net::DBus - The 'find' method on Net::DBus will search for & attach to a suitable bus, so no longer neccessary to hard code either system or session bus - Introspection data is no longer provided via the Net::DBus::Object constructor. Consult the manual pages for Net::DBus::OBject and Net::DBus::Exporter for details of new approach to defining introspection data. - The Net::DBus::Introspector class is no longer for public use. - The Net::DBus::Dumper class can be used to display a dump of an object's exported API cf examples/dump-object.pl - Signal handler callbacks now get the actual signal params passed in, rather than low level bind info - The Net::DBus objects are automatically registered with the default reactor mainloop, unless 'nomainloop => 1' is passed into constructor Net-DBus-1.0.0/t/0000755000076500007650000000000011603165554013510 5ustar berrangeberrangeNet-DBus-1.0.0/t/05-pod.t0000644000076500007650000000025511603165524014700 0ustar berrangeberrange# -*- perl -*- use Test::More; use strict; use warnings; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-DBus-1.0.0/t/10-pod-coverage.t0000644000076500007650000000031511603165524016462 0ustar berrangeberrange# -*- perl -*- use Test::More; use strict; use warnings; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); Net-DBus-1.0.0/t/15-message.t0000644000076500007650000000463711603165524015553 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 33; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Iterator'); use_ok('Net::DBus::Binding::Message::Signal'); use_ok('Net::DBus::Binding::Message::MethodCall'); use_ok('Net::DBus::Binding::Message::MethodReturn'); use_ok('Net::DBus::Binding::Message::Error'); }; my $msg = Net::DBus::Binding::Message::Signal->new(object_path => "/foo/bar/Wizz", interface => "com.blah.Example", signal_name => "Eeek"); my $iter = $msg->iterator(1); $iter->append_boolean(1); $iter->append_byte(43); $iter->append_int16(123); $iter->append_uint16(456); $iter->append_int32(123); $iter->append_uint32(456); $iter->append_int64("12345645645"); $iter->append_uint64("12312312312"); $iter->append_int64("12345645645123456"); $iter->append_uint64("12312312312123456"); $iter->append_string("Hello world"); $iter->append_double(1.424141); $iter->append_array(["one", "two", "three"], [&Net::DBus::Binding::Message::TYPE_STRING]); $iter->append_dict({ "one" => "foo", "two" => "bar"}, [&Net::DBus::Binding::Message::TYPE_STRING, &Net::DBus::Binding::Message::TYPE_STRING]); $iter = $msg->iterator(); ok($iter->get_boolean() == 1, "boolean"); ok($iter->next(), "next"); ok($iter->get_byte() == 43, "byte"); ok($iter->next(), "next"); ok($iter->get_int16() == 123, "int16"); ok($iter->next(), "next"); ok($iter->get_uint16() == 456, "uint16"); ok($iter->next(), "next"); ok($iter->get_int32() == 123, "int32"); ok($iter->next(), "next"); ok($iter->get_uint32() == 456, "uint32"); ok($iter->next(), "next"); ok($iter->get_int64() == "12345645645", "int64"); ok($iter->next(), "next"); ok($iter->get_uint64() == "12312312312", "uint64"); ok($iter->next(), "next"); ok($iter->get_int64() == "12345645645123456", "int64"); ok($iter->next(), "next"); ok($iter->get_uint64() == "12312312312123456", "uint64"); ok($iter->next(), "next"); ok($iter->get_string() eq "Hello world", "string"); ok($iter->next(), "next"); # Don't test precise equality, because floating point arithmetic # is not an exact science. (see RT #37707) my $d = $iter->get_double(); ok($d > 1.424100 && $d < 1.424200, "double"); ok($iter->next(), "next"); is_deeply($iter->get_array(&Net::DBus::Binding::Message::TYPE_STRING), ["one", "two", "three"], "array"); ok($iter->next(), "next"); is_deeply($iter->get_dict(), {"one" => "foo", "two" => "bar"}, "dict"); ok(!$iter->next(), "next"); Net-DBus-1.0.0/t/65-object-magic.t0000644000076500007650000001255511603165524016456 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 13; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); use_ok('Net::DBus::Object'); }; package MyObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.example.MyObject); dbus_method("test_set_serial", ["serial"]); sub test_set_serial { my $self = shift; my @args = @_; $self->{lastargs} = \@args; } dbus_method("test_set_caller", ["caller"]); sub test_set_caller { my $self = shift; my @args = @_; $self->{lastargs} = \@args; } dbus_method("test_set_multi_args1", ["string", "caller"]); sub test_set_multi_args1 { my $self = shift; my @args = @_; $self->{lastargs} = \@args; } dbus_method("test_set_multi_args2", ["caller", "string"]); sub test_set_multi_args2 { my $self = shift; my @args = @_; $self->{lastargs} = \@args; } dbus_method("test_set_multi_args3", ["string", "caller", "string"]); sub test_set_multi_args3 { my $self = shift; my @args = @_; $self->{lastargs} = \@args; } package main; my $bus = Net::DBus->test; my $service = $bus->export_service("/org/cpan/Net/Bus/test"); my $object = MyObject->new($service, "/org/example/MyObject"); my $introspector = $object->_introspector; my $xml_got = $introspector->format($object); my $xml_expect = < EOF is($xml_got, $xml_expect, "xml data matches"); CALLER: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.example.MyObject", method_name => "test_set_caller"); $msg->set_sender(":1.1"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is_deeply($object->{lastargs}, [":1.1"], "caller is :1.1"); } SERIAL: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.example.MyObject", method_name => "test_set_serial"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is_deeply($object->{lastargs}, [$msg->get_serial], "serial matches"); } MULTI_ARGS1: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.example.MyObject", method_name => "test_set_multi_args1"); $msg->set_sender(":1.1"); my $iter = $msg->iterator(1); $iter->append_string("one"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is_deeply($object->{lastargs}, ["one",":1.1"], "caller matches"); } MULTI_ARGS2: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.example.MyObject", method_name => "test_set_multi_args2"); $msg->set_sender(":1.1"); my $iter = $msg->iterator(1); $iter->append_string("one"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is_deeply($object->{lastargs}, [":1.1", "one"], "caller matches"); } MULTI_ARGS3: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.example.MyObject", method_name => "test_set_multi_args3"); $msg->set_sender(":1.1"); my $iter = $msg->iterator(1); $iter->append_string("one"); $iter->append_string("two"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is_deeply($object->{lastargs}, ["one",":1.1", "two"], "caller matches"); } Net-DBus-1.0.0/t/30-server.t0000644000076500007650000000221311603165524015416 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 11; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Server'); use_ok('Net::DBus::Binding::Connection'); use_ok('Net::DBus::Reactor'); use_ok('Net::DBus::Binding::Message::Signal'); } my $server = Net::DBus::Binding::Server->new(address => "unix:path=/tmp/dbus-perl-test-$$"); ok ($server->is_connected, "server connected"); my $reactor = Net::DBus::Reactor->new(); $reactor->manage($server); my $incoming; $server->set_connection_callback(sub { $server = shift; $incoming = shift; }); my $client = Net::DBus::Binding::Connection->new(address => "unix:path=/tmp/dbus-perl-test-$$", private => 1); ok ($client->is_connected, "client connected"); $reactor->manage($client); $reactor->{running} = 1; $reactor->step; ok (defined $incoming, "incoming"); ok ($incoming->is_connected, "incoming connected"); #$reactor->manage($incoming); $client->disconnect; ok (!$client->is_connected, "client disconnected"); $incoming->disconnect; ok (!$incoming->is_connected, "incoming disconnected"); $server->disconnect; ok (!$server->is_connected, "server disconnected"); Net-DBus-1.0.0/t/56-scalar-param-typing.t0000644000076500007650000012546011603165524020005 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 382; use Carp qw(confess); $SIG{__DIE__} = sub { confess $_[0] }; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector') or die; use_ok('Net::DBus::Object') or die; use_ok('Net::DBus::Test::MockObject') or die; use_ok("Net::DBus", qw(:typing)) or die; }; TEST_NO_INTROSPECT: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; ##### String tests $myobject->ScalarString("Foo"); is($object->get_last_message_signature, "s", "string as string"); is($object->get_last_message_param, "Foo", "string as string"); $myobject->ScalarString(2); is($object->get_last_message->get_signature, "s", "int as string"); is($object->get_last_message_param, "2", "int as string"); $myobject->ScalarString(5.234); is($object->get_last_message->get_signature, "s", "double as string"); is($object->get_last_message_param, "5.234", "double as string"); #### INT 16 tests # Positive integers $myobject->ScalarInt16("2"); is($object->get_last_message_signature, "s", "string as int16"); is($object->get_last_message_param, "2", "string as int16"); $myobject->ScalarInt16(2); is($object->get_last_message_signature, "s", "int as int16"); is($object->get_last_message_param, "2", "int as int16"); $myobject->ScalarInt16(2.0); is($object->get_last_message_signature, "s", "double as int16"); is($object->get_last_message_param, "2", "double as int16"); # Negative integers $myobject->ScalarInt16("-2"); is($object->get_last_message_signature, "s", "-ve string as int16"); is($object->get_last_message_param, "-2", "-ve string as int16"); $myobject->ScalarInt16(-2); is($object->get_last_message_signature, "s", "-ve int as int16"); is($object->get_last_message_param, "-2", "-ve int as int16"); $myobject->ScalarInt16(-2.0); is($object->get_last_message_signature, "s", "-ve double as int16"); is($object->get_last_message_param, "-2", "-ve double as int16"); # Rounding of doubles $myobject->ScalarInt16(2.1); is($object->get_last_message_signature, "s", "round down double as int16"); is($object->get_last_message_param, "2.1", "round down double as int16"); $myobject->ScalarInt16(2.9); is($object->get_last_message_signature, "s", "round up double as int16"); is($object->get_last_message_param, "2.9", "round up double as int16"); $myobject->ScalarInt16(2.5); is($object->get_last_message_signature, "s", "round up double threshold as int16"); is($object->get_last_message_param, "2.5", "round up double threshold as int16"); $myobject->ScalarInt16(-2.1); is($object->get_last_message_signature, "s", "-ve round up double as int16"); is($object->get_last_message_param, "-2.1", "-ve round up double as int16"); $myobject->ScalarInt16(-2.9); is($object->get_last_message_signature, "s", "-ve round down double as int16"); is($object->get_last_message_param, "-2.9", "-ve round down double as int16"); $myobject->ScalarInt16(-2.5); is($object->get_last_message_signature, "s", "-ve round down double threshold as int16"); is($object->get_last_message_param, "-2.5", "-ve round down double threshold as int16"); #### UINT 16 tests # Positive integers $myobject->ScalarUInt16("2"); is($object->get_last_message_signature, "s", "string as uint16"); is($object->get_last_message_param, "2", "string as uint16"); $myobject->ScalarUInt16(2); is($object->get_last_message_signature, "s", "int as uint16"); is($object->get_last_message_param, "2", "int as uint16"); $myobject->ScalarUInt16(2.0); is($object->get_last_message_signature, "s", "double as uint16"); is($object->get_last_message_param, "2", "double as uint16"); # Negative integers $myobject->ScalarUInt16("-2"); is($object->get_last_message_signature, "s", "-ve string as uint16"); is($object->get_last_message_param, "-2", "-ve string as uint16"); $myobject->ScalarUInt16(-2); is($object->get_last_message_signature, "s", "-ve int as uint16"); is($object->get_last_message_param, "-2", "-ve int as uint16"); $myobject->ScalarUInt16(-2.0); is($object->get_last_message_signature, "s", "-ve double as uint16"); is($object->get_last_message_param, "-2", "-ve double as uint16"); # Rounding of doubles $myobject->ScalarUInt16(2.1); is($object->get_last_message_signature, "s", "round down double as uint16"); is($object->get_last_message_param, "2.1", "round down double as uint16"); $myobject->ScalarUInt16(2.9); is($object->get_last_message_signature, "s", "round up double as uint16"); is($object->get_last_message_param, "2.9", "round up double as uint16"); $myobject->ScalarUInt16(2.5); is($object->get_last_message_signature, "s", "round up double threshold as uint16"); is($object->get_last_message_param, "2.5", "round up double threshold as uint16"); #### INT 32 tests # Positive integers $myobject->ScalarInt32("2"); is($object->get_last_message_signature, "s", "string as int32"); is($object->get_last_message_param, "2", "string as int32"); $myobject->ScalarInt32(2); is($object->get_last_message_signature, "s", "int as int32"); is($object->get_last_message_param, "2", "int as int32"); $myobject->ScalarInt32(2.0); is($object->get_last_message_signature, "s", "double as int32"); is($object->get_last_message_param, "2", "double as int32"); # Negative integers $myobject->ScalarInt32("-2"); is($object->get_last_message_signature, "s", "-ve string as int32"); is($object->get_last_message_param, "-2", "-ve string as int32"); $myobject->ScalarInt32(-2); is($object->get_last_message_signature, "s", "-ve int as int32"); is($object->get_last_message_param, "-2", "-ve int as int32"); $myobject->ScalarInt32(-2.0); is($object->get_last_message_signature, "s", "-ve double as int32"); is($object->get_last_message_param, "-2", "-ve double as int32"); # Rounding of doubles $myobject->ScalarInt32(2.1); is($object->get_last_message_signature, "s", "round down double as int32"); is($object->get_last_message_param, "2.1", "round down double as int32"); $myobject->ScalarInt32(2.9); is($object->get_last_message_signature, "s", "round up double as int32"); is($object->get_last_message_param, "2.9", "round up double as int32"); $myobject->ScalarInt32(2.5); is($object->get_last_message_signature, "s", "round up double threshold as int32"); is($object->get_last_message_param, "2.5", "round up double threshold as int32"); $myobject->ScalarInt32(-2.1); is($object->get_last_message_signature, "s", "-ve round up double as int32"); is($object->get_last_message_param, "-2.1", "-ve round up double as int32"); $myobject->ScalarInt32(-2.9); is($object->get_last_message_signature, "s", "-ve round down double as int32"); is($object->get_last_message_param, "-2.9", "-ve round down double as int32"); $myobject->ScalarInt32(-2.5); is($object->get_last_message_signature, "s", "-ve round down double threshold as int32"); is($object->get_last_message_param, "-2.5", "-ve round down double threshold as int32"); #### UINT 32 tests # Positive integers $myobject->ScalarUInt32("2"); is($object->get_last_message_signature, "s", "string as uint32"); is($object->get_last_message_param, "2", "string as uint32"); $myobject->ScalarUInt32(2); is($object->get_last_message_signature, "s", "int as uint32"); is($object->get_last_message_param, "2", "int as uint32"); $myobject->ScalarUInt32(2.0); is($object->get_last_message_signature, "s", "double as uint32"); is($object->get_last_message_param, "2", "double as uint32"); # Negative integers $myobject->ScalarUInt32("-2"); is($object->get_last_message_signature, "s", "-ve string as uint32"); is($object->get_last_message_param, "-2", "-ve string as uint32"); $myobject->ScalarUInt32(-2); is($object->get_last_message_signature, "s", "-ve int as uint32"); is($object->get_last_message_param, "-2", "-ve int as uint32"); $myobject->ScalarUInt32(-2.0); is($object->get_last_message_signature, "s", "-ve double as uint32"); is($object->get_last_message_param, "-2", "-ve double as uint32"); # Rounding of doubles $myobject->ScalarUInt32(2.1); is($object->get_last_message_signature, "s", "round down double as uint32"); is($object->get_last_message_param, "2.1", "round down double as uint32"); $myobject->ScalarUInt32(2.9); is($object->get_last_message_signature, "s", "round up double as uint32"); is($object->get_last_message_param, "2.9", "round up double as uint32"); $myobject->ScalarUInt32(2.5); is($object->get_last_message_signature, "s", "round up double threshold as uint32"); is($object->get_last_message_param, "2.5", "round up double threshold as uint32"); #### Double tests # Double $myobject->ScalarDouble(5.234); is($object->get_last_message_signature, "s", "double as double"); is($object->get_last_message_param, "5.234", "double as double"); # Stringized Double $myobject->ScalarDouble("2.1"); is($object->get_last_message_signature, "s", "string as double"); is($object->get_last_message_param, "2.1", "string as double"); # Integer -> double conversion $myobject->ScalarDouble(2); is($object->get_last_message_signature, "s", "int as double"); is($object->get_last_message_param, "2", "int as double"); # -ve Double $myobject->ScalarDouble(-5.234); is($object->get_last_message_signature, "s", "-ve double as double"); is($object->get_last_message_param, "-5.234", "-ve double as double"); # -ve Stringized Double $myobject->ScalarDouble("-2.1"); is($object->get_last_message_signature, "s", "-ve string as double"); is($object->get_last_message_param, "-2.1", "-ve string as double"); # -ve Integer -> double conversion $myobject->ScalarDouble(-2); is($object->get_last_message_signature, "s", "-ve int as double"); is($object->get_last_message_param, "-2", "-ve int as double"); #### Byte tests # Int $myobject->ScalarByte(7); is($object->get_last_message_signature, "s", "int as byte"); is($object->get_last_message_param, "7", "int as byte"); # Double roudning $myobject->ScalarByte(2.6); is($object->get_last_message_signature, "s", "double as byte"); is($object->get_last_message_param, "2.6", "double as byte"); # Range overflow $myobject->ScalarByte(10000); is($object->get_last_message_signature, "s", "int as byte overflow"); is($object->get_last_message_param, "10000", "int as byte overflow"); # -ve Int $myobject->ScalarByte(-7); is($object->get_last_message_signature, "s", "-ve int as byte"); is($object->get_last_message_param, "-7", "-ve int as byte"); # -ve Double roudning $myobject->ScalarByte(-2.6); is($object->get_last_message_signature, "s", "double as byte"); is($object->get_last_message_param, "-2.6", "double as byte"); # -ve Range overflow $myobject->ScalarByte(-10000); is($object->get_last_message_signature, "s", "-ve int as byte overflow"); is($object->get_last_message_param, "-10000", "-ve int as byte overflow"); ##### Boolean # String, O and false $myobject->ScalarBoolean("0"); is($object->get_last_message_signature, "s", "string as boolean, 0 and false"); is($object->get_last_message_param, "0", "string as boolean, 0 and false"); # String, O but true $myobject->ScalarBoolean("0true"); is($object->get_last_message_signature, "s", "string as boolean, 0 but true"); is($object->get_last_message_param, "0true", "string as boolean, 0 but true"); # String, 1 and true $myobject->ScalarBoolean("1true"); is($object->get_last_message_signature, "s", "string as boolean, 1 and true"); is($object->get_last_message_param, "1true", "string as boolean, 1 and true"); # Int true $myobject->ScalarBoolean(1); is($object->get_last_message_signature, "s", "int as boolean, true"); is($object->get_last_message_param, "1", "int as boolean, true"); # Int false $myobject->ScalarBoolean(0); is($object->get_last_message_signature, "s", "int as boolean, false"); is($object->get_last_message_param, "0", "int as boolean, false"); # Undefined and false $myobject->ScalarBoolean(undef); is($object->get_last_message_signature, "s", "undefined as boolean, false"); is($object->get_last_message_param, "", "undefined as boolean, false"); } TEST_MANUAL_TYPING: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; ##### String tests $myobject->ScalarString("Foo"); is($object->get_last_message_signature, "s", "string as string"); is($object->get_last_message_param, "Foo", "string as string"); $myobject->ScalarString(2); is($object->get_last_message->get_signature, "s", "int as string"); is($object->get_last_message_param, "2", "int as string"); $myobject->ScalarString(5.234); is($object->get_last_message->get_signature, "s", "double as string"); is($object->get_last_message_param, "5.234", "double as string"); #### INT 16 tests # Positive integers $myobject->ScalarInt16(dbus_int16("2")); is($object->get_last_message_signature, "n", "string as int16"); is($object->get_last_message_param, 2, "string as int16"); $myobject->ScalarInt16(dbus_int16(2)); is($object->get_last_message_signature, "n", "int as int16"); is($object->get_last_message_param, 2, "int as int16"); $myobject->ScalarInt16(dbus_int16(2.0)); is($object->get_last_message_signature, "n", "double as int16"); is($object->get_last_message_param, 2, "double as int16"); # Negative integers $myobject->ScalarInt16(dbus_int16("-2")); is($object->get_last_message_signature, "n", "-ve string as int16"); is($object->get_last_message_param, -2, "-ve string as int16"); $myobject->ScalarInt16(dbus_int16(-2)); is($object->get_last_message_signature, "n", "-ve int as int16"); is($object->get_last_message_param, -2, "-ve int as int16"); $myobject->ScalarInt16(dbus_int16(-2.0)); is($object->get_last_message_signature, "n", "-ve double as int16"); is($object->get_last_message_param, -2, "-ve double as int16"); # Rounding of doubles $myobject->ScalarInt16(dbus_int16(2.1)); is($object->get_last_message_signature, "n", "round down double as int16"); is($object->get_last_message_param, 2, "round down double as int16"); $myobject->ScalarInt16(dbus_int16(2.9)); is($object->get_last_message_signature, "n", "round up double as int16"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as int16"); } $myobject->ScalarInt16(dbus_int16(2.5)); is($object->get_last_message_signature, "n", "round up double threshold as int16"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as int16"); } $myobject->ScalarInt16(dbus_int16(-2.1)); is($object->get_last_message_signature, "n", "-ve round up double as int16"); is($object->get_last_message_param, -2, "-ve round up double as int16"); $myobject->ScalarInt16(dbus_int16(-2.9)); is($object->get_last_message_signature, "n", "-ve round down double as int16"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, -3, "-ve round down double as int16"); } $myobject->ScalarInt16(dbus_int16(-2.5)); is($object->get_last_message_signature, "n", "-ve round down double threshold as int16"); is($object->get_last_message_param, -2, "-ve round down double threshold as int16"); #### UINT 16 tests # Positive integers $myobject->ScalarUInt16(dbus_uint16("2")); is($object->get_last_message_signature, "q", "string as uint16"); is($object->get_last_message_param, 2, "string as uint16"); $myobject->ScalarUInt16(dbus_uint16(2)); is($object->get_last_message_signature, "q", "int as uint16"); is($object->get_last_message_param, 2, "int as uint16"); $myobject->ScalarUInt16(dbus_uint16(2.0)); is($object->get_last_message_signature, "q", "double as uint16"); is($object->get_last_message_param, 2, "double as uint16"); # Negative integers $myobject->ScalarUInt16(dbus_uint16("-2")); is($object->get_last_message_signature, "q", "-ve string as uint16"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve string as uint16"); } $myobject->ScalarUInt16(dbus_uint16(-2)); is($object->get_last_message_signature, "q", "-ve int as uint16"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve int as uint16"); } $myobject->ScalarUInt16(dbus_uint16(-2.0)); is($object->get_last_message_signature, "q", "-ve double as uint16"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve double as uint16"); } # Rounding of doubles $myobject->ScalarUInt16(dbus_uint16(2.1)); is($object->get_last_message_signature, "q", "round down double as uint16"); is($object->get_last_message_param, 2, "round down double as uint16"); $myobject->ScalarUInt16(dbus_uint16(2.9)); is($object->get_last_message_signature, "q", "round up double as uint16"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as uint16"); } $myobject->ScalarUInt16(dbus_uint16(2.5)); is($object->get_last_message_signature, "q", "round up double threshold as uint16"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as uint16"); } #### INT 32 tests # Positive integers $myobject->ScalarInt32(dbus_int32("2")); is($object->get_last_message_signature, "i", "string as int32"); is($object->get_last_message_param, 2, "string as int32"); $myobject->ScalarInt32(dbus_int32(2)); is($object->get_last_message_signature, "i", "int as int32"); is($object->get_last_message_param, 2, "int as int32"); $myobject->ScalarInt32(dbus_int32(2.0)); is($object->get_last_message_signature, "i", "double as int32"); is($object->get_last_message_param, 2, "double as int32"); # Negative integers $myobject->ScalarInt32(dbus_int32("-2")); is($object->get_last_message_signature, "i", "-ve string as int32"); is($object->get_last_message_param, -2, "-ve string as int32"); $myobject->ScalarInt32(dbus_int32(-2)); is($object->get_last_message_signature, "i", "-ve int as int32"); is($object->get_last_message_param, -2, "-ve int as int32"); $myobject->ScalarInt32(dbus_int32(-2.0)); is($object->get_last_message_signature, "i", "-ve double as int32"); is($object->get_last_message_param, -2, "-ve double as int32"); # Rounding of doubles $myobject->ScalarInt32(dbus_int32(2.1)); is($object->get_last_message_signature, "i", "round down double as int32"); is($object->get_last_message_param, 2, "round down double as int32"); $myobject->ScalarInt32(dbus_int32(2.9)); is($object->get_last_message_signature, "i", "round up double as int32"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as int32"); } $myobject->ScalarInt32(dbus_int32(2.5)); is($object->get_last_message_signature, "i", "round up double threshold as int32"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as int32"); } $myobject->ScalarInt32(dbus_int32(-2.1)); is($object->get_last_message_signature, "i", "-ve round up double as int32"); is($object->get_last_message_param, -2, "-ve round up double as int32"); $myobject->ScalarInt32(dbus_int32(-2.9)); is($object->get_last_message_signature, "i", "-ve round down double as int32"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, -3, "-ve round down double as int32"); } $myobject->ScalarInt32(dbus_int32(-2.5)); is($object->get_last_message_signature, "i", "-ve round down double threshold as int32"); is($object->get_last_message_param, -2, "-ve round down double threshold as int32"); #### UINT 32 tests # Positive integers $myobject->ScalarUInt32(dbus_uint32("2")); is($object->get_last_message_signature, "u", "string as uint32"); is($object->get_last_message_param, 2, "string as uint32"); $myobject->ScalarUInt32(dbus_uint32(2)); is($object->get_last_message_signature, "u", "int as uint32"); is($object->get_last_message_param, 2, "int as uint32"); $myobject->ScalarUInt32(dbus_uint32(2.0)); is($object->get_last_message_signature, "u", "double as uint32"); is($object->get_last_message_param, 2, "double as uint32"); # Negative integers $myobject->ScalarUInt32(dbus_uint32("-2")); is($object->get_last_message_signature, "u", "-ve string as uint32"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve string as uint32"); } $myobject->ScalarUInt32(dbus_uint32(-2)); is($object->get_last_message_signature, "u", "-ve int as uint32"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve int as uint32"); } $myobject->ScalarUInt32(dbus_uint32(-2.0)); is($object->get_last_message_signature, "u", "-ve double as uint32"); SKIP: { skip "sign truncation is wrong", 1; is($object->get_last_message_param, -2, "-ve double as uint32"); } # Rounding of doubles $myobject->ScalarUInt32(dbus_uint32(2.1)); is($object->get_last_message_signature, "u", "round down double as uint32"); is($object->get_last_message_param, 2, "round down double as uint32"); $myobject->ScalarUInt32(dbus_uint32(2.9)); is($object->get_last_message_signature, "u", "round up double as uint32"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as uint32"); } $myobject->ScalarUInt32(dbus_uint32(2.5)); is($object->get_last_message_signature, "u", "round up double threshold as uint32"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as uint32"); } #### Double tests # Double $myobject->ScalarDouble(dbus_double(5.234)); is($object->get_last_message_signature, "d", "double as double"); is($object->get_last_message_param, 5.234, "double as double"); # Stringized Double $myobject->ScalarDouble(dbus_double("2.1")); is($object->get_last_message_signature, "d", "string as double"); is($object->get_last_message_param, 2.1, "string as double"); # Integer -> double conversion $myobject->ScalarDouble(dbus_double(2)); is($object->get_last_message_signature, "d", "int as double"); is($object->get_last_message_param, 2.0, "int as double"); # -ve Double $myobject->ScalarDouble(dbus_double(-5.234)); is($object->get_last_message_signature, "d", "-ve double as double"); is($object->get_last_message_param, -5.234, "-ve double as double"); # -ve Stringized Double $myobject->ScalarDouble(dbus_double("-2.1")); is($object->get_last_message_signature, "d", "-ve string as double"); is($object->get_last_message_param, -2.1, "-ve string as double"); # -ve Integer -> double conversion $myobject->ScalarDouble(dbus_double(-2)); is($object->get_last_message_signature, "d", "-ve int as double"); is($object->get_last_message_param, -2.0, "-ve int as double"); #### Byte tests # Int $myobject->ScalarByte(dbus_byte(7)); is($object->get_last_message_signature, "y", "int as byte"); is($object->get_last_message_param, 7, "int as byte"); # Double roudning $myobject->ScalarByte(dbus_byte(2.6)); is($object->get_last_message_signature, "y", "double as byte"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 3, "double as byte"); } # Range overflow $myobject->ScalarByte(dbus_byte(10000)); is($object->get_last_message_signature, "y", "int as byte overflow"); SKIP: { skip "rounding actually truncates", 1; is($object->get_last_message_param, 10000, "int as byte overflow"); } # -ve Int $myobject->ScalarByte(dbus_byte(-7)); is($object->get_last_message_signature, "y", "-ve int as byte"); SKIP: { skip "sign truncation broken", 1; is($object->get_last_message_param, -7, "-ve int as byte"); } # -ve Double roudning $myobject->ScalarByte(dbus_byte(-2.6)); is($object->get_last_message_signature, "y", "double as byte"); SKIP: { skip "sign truncation broken", 1; is($object->get_last_message_param, -3, "double as byte"); } # -ve Range overflow $myobject->ScalarByte(dbus_byte(-10000)); is($object->get_last_message_signature, "y", "-ve int as byte overflow"); SKIP: { skip "sign truncation broken", 1; is($object->get_last_message_param, -10000, "-ve int as byte overflow"); } ##### Boolean # String, O and false $myobject->ScalarBoolean(dbus_boolean("0")); is($object->get_last_message_signature, "b", "string as boolean, 0 and false"); is($object->get_last_message_param, '', "string as boolean, 0 and false"); # String, O but true $myobject->ScalarBoolean(dbus_boolean("0true")); is($object->get_last_message_signature, "b", "string as boolean, 0 but true"); is($object->get_last_message_param, '1', "string as boolean, 0 but true"); # String, 1 and true $myobject->ScalarBoolean(dbus_boolean("1true")); is($object->get_last_message_signature, "b", "string as boolean, 1 and true"); is($object->get_last_message_param, '1', "string as boolean, 1 and true"); # Int true $myobject->ScalarBoolean(dbus_boolean(1)); is($object->get_last_message_signature, "b", "int as boolean, true"); is($object->get_last_message_param, '1', "int as boolean, true"); # Int false $myobject->ScalarBoolean(dbus_boolean(0)); is($object->get_last_message_signature, "b", "int as boolean, false"); is($object->get_last_message_param, '', "int as boolean, false"); # Undefined and false $myobject->ScalarBoolean(dbus_boolean(undef)); is($object->get_last_message_signature, "b", "undefined as boolean, false"); is($object->get_last_message_param, '', "undefined as boolean, false"); } TEST_INTROSPECT_TYPING: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; my $ins = Net::DBus::Binding::Introspector->new(); $ins->add_method("ScalarString", ["string"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject", {}, []); $ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject", {}, []); $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", reply => { return => [ $ins->format($object) ] }); ##### String tests $myobject->ScalarString("Foo"); is($object->get_last_message_signature, "s", "string as string"); is($object->get_last_message_param, "Foo", "string as string"); $myobject->ScalarString(2); is($object->get_last_message->get_signature, "s", "int as string"); is($object->get_last_message_param, "2", "int as string"); $myobject->ScalarString(5.234); is($object->get_last_message->get_signature, "s", "double as string"); is($object->get_last_message_param, "5.234", "double as string"); #### INT 16 tests # Positive integers $myobject->ScalarInt16("2"); is($object->get_last_message_signature, "n", "string as int16"); is($object->get_last_message_param, 2, "string as int16"); $myobject->ScalarInt16(2); is($object->get_last_message_signature, "n", "int as int16"); is($object->get_last_message_param, 2, "int as int16"); $myobject->ScalarInt16(2.0); is($object->get_last_message_signature, "n", "double as int16"); is($object->get_last_message_param, 2, "double as int16"); # Negative integers $myobject->ScalarInt16("-2"); is($object->get_last_message_signature, "n", "-ve string as int16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2", "-ve string as int16"); } $myobject->ScalarInt16(-2); is($object->get_last_message_signature, "n", "-ve int as int16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2", "-ve int as int16"); } $myobject->ScalarInt16(-2.0); is($object->get_last_message_signature, "n", "-ve double as int16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2.0", "-ve double as int16"); } # Rounding of doubles $myobject->ScalarInt16(2.1); is($object->get_last_message_signature, "n", "round down double as int16"); is($object->get_last_message_param, 2, "round down double as int16"); $myobject->ScalarInt16(2.9); is($object->get_last_message_signature, "n", "round up double as int16"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as int16"); } $myobject->ScalarInt16(2.5); is($object->get_last_message_signature, "n", "round up double threshold as int16"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as int16"); } $myobject->ScalarInt16(-2.1); is($object->get_last_message_signature, "n", "-ve round up double as int16"); is($object->get_last_message_param, -2, "-ve round up double as int16"); $myobject->ScalarInt16(-2.9); is($object->get_last_message_signature, "n", "-ve round down double as int16"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, -3, "-ve round down double as int16"); } $myobject->ScalarInt16(-2.5); is($object->get_last_message_signature, "n", "-ve round down double threshold as int16"); is($object->get_last_message_param, -2, "-ve round down double threshold as int16"); #### UINT 16 tests # Positive integers $myobject->ScalarUInt16("2"); is($object->get_last_message_signature, "q", "string as uint16"); is($object->get_last_message_param, 2, "string as uint16"); $myobject->ScalarUInt16(2); is($object->get_last_message_signature, "q", "int as uint16"); is($object->get_last_message_param, 2, "int as uint16"); $myobject->ScalarUInt16(2.0); is($object->get_last_message_signature, "q", "double as uint16"); is($object->get_last_message_param, 2, "double as uint16"); # Negative integers $myobject->ScalarUInt16("-2"); is($object->get_last_message_signature, "q", "-ve string as uint16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve string as uint16"); } $myobject->ScalarUInt16(-2); is($object->get_last_message_signature, "q", "-ve int as uint16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve int as uint16"); } $myobject->ScalarUInt16(-2.0); is($object->get_last_message_signature, "q", "-ve double as uint16"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve double as uint16"); } # Rounding of doubles $myobject->ScalarUInt16(2.1); is($object->get_last_message_signature, "q", "round down double as uint16"); is($object->get_last_message_param, 2, "round down double as uint16"); $myobject->ScalarUInt16(2.9); is($object->get_last_message_signature, "q", "round up double as uint16"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as uint16"); } $myobject->ScalarUInt16(2.5); is($object->get_last_message_signature, "q", "round up double threshold as uint16"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as uint16"); } #### INT 32 tests # Positive integers $myobject->ScalarInt32("2"); is($object->get_last_message_signature, "i", "string as int32"); is($object->get_last_message_param, 2, "string as int32"); $myobject->ScalarInt32(2); is($object->get_last_message_signature, "i", "int as int32"); is($object->get_last_message_param, 2, "int as int32"); $myobject->ScalarInt32(2.0); is($object->get_last_message_signature, "i", "double as int32"); is($object->get_last_message_param, 2, "double as int32"); # Negative integers $myobject->ScalarInt32("-2"); is($object->get_last_message_signature, "i", "-ve string as int32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2", "-ve string as int32"); } $myobject->ScalarInt32(-2); is($object->get_last_message_signature, "i", "-ve int as int32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2", "-ve int as int32"); } $myobject->ScalarInt32(-2.0); is($object->get_last_message_signature, "i", "-ve double as int32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, "-2.0", "-ve double as int32"); } # Rounding of doubles $myobject->ScalarInt32(2.1); is($object->get_last_message_signature, "i", "round down double as int32"); is($object->get_last_message_param, 2, "round down double as int32"); $myobject->ScalarInt32(2.9); is($object->get_last_message_signature, "i", "round up double as int32"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as int32"); } $myobject->ScalarInt32(2.5); is($object->get_last_message_signature, "i", "round up double threshold as int32"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as int32"); } $myobject->ScalarInt32(-2.1); is($object->get_last_message_signature, "i", "-ve round up double as int32"); is($object->get_last_message_param, -2, "-ve round up double as int32"); $myobject->ScalarInt32(-2.9); is($object->get_last_message_signature, "i", "-ve round down double as int32"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, -3, "-ve round down double as int32"); } $myobject->ScalarInt32(-2.5); is($object->get_last_message_signature, "i", "-ve round down double threshold as int32"); is($object->get_last_message_param, -2, "-ve round down double threshold as int32"); #### UINT 32 tests # Positive integers $myobject->ScalarUInt32("2"); is($object->get_last_message_signature, "u", "string as uint32"); is($object->get_last_message_param, 2, "string as uint32"); $myobject->ScalarUInt32(2); is($object->get_last_message_signature, "u", "int as uint32"); is($object->get_last_message_param, 2, "int as uint32"); $myobject->ScalarUInt32(2.0); is($object->get_last_message_signature, "u", "double as uint32"); is($object->get_last_message_param, 2, "double as uint32"); # Negative integers $myobject->ScalarUInt32("-2"); is($object->get_last_message_signature, "u", "-ve string as uint32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve string as uint32"); } $myobject->ScalarUInt32(-2); is($object->get_last_message_signature, "u", "-ve int as uint32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve int as uint32"); } $myobject->ScalarUInt32(-2.0); is($object->get_last_message_signature, "u", "-ve double as uint32"); SKIP: { skip "sign truncation not checked", 1; is($object->get_last_message_param, -2, "-ve double as uint32"); } # Rounding of doubles $myobject->ScalarUInt32(2.1); is($object->get_last_message_signature, "u", "round down double as uint32"); is($object->get_last_message_param, 2, "round down double as uint32"); $myobject->ScalarUInt32(2.9); is($object->get_last_message_signature, "u", "round up double as uint32"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double as uint32"); } $myobject->ScalarUInt32(2.5); is($object->get_last_message_signature, "u", "round up double threshold as uint32"); SKIP: { skip "double -> int rounding actually truncates", 1; is($object->get_last_message_param, 3, "round up double threshold as uint32"); } #### Double tests # Double $myobject->ScalarDouble(5.234); is($object->get_last_message_signature, "d", "double as double"); is($object->get_last_message_param, 5.234, "double as double"); # Stringized Double $myobject->ScalarDouble("2.1"); is($object->get_last_message_signature, "d", "string as double"); is($object->get_last_message_param, 2.1, "string as double"); # Integer -> double conversion $myobject->ScalarDouble(2); is($object->get_last_message_signature, "d", "int as double"); is($object->get_last_message_param, 2.0, "int as double"); # -ve Double $myobject->ScalarDouble(-5.234); is($object->get_last_message_signature, "d", "-ve double as double"); is($object->get_last_message_param, -5.234, "-ve double as double"); # -ve Stringized Double $myobject->ScalarDouble("-2.1"); is($object->get_last_message_signature, "d", "-ve string as double"); is($object->get_last_message_param, -2.1, "-ve string as double"); # -ve Integer -> double conversion $myobject->ScalarDouble(-2); is($object->get_last_message_signature, "d", "-ve int as double"); is($object->get_last_message_param, -2.0, "-ve int as double"); #### Byte tests # Int $myobject->ScalarByte(7); is($object->get_last_message_signature, "y", "int as byte"); is($object->get_last_message_param, 7, "int as byte"); # Double roudning $myobject->ScalarByte(2.6); is($object->get_last_message_signature, "y", "double as byte"); SKIP: { skip "double rounding not sorted", 1; is($object->get_last_message_param, 3, "double as byte"); } # Range overflow $myobject->ScalarByte(10000); is($object->get_last_message_signature, "y", "int as byte overflow"); SKIP: { skip "byte overflow not checked", 1; is($object->get_last_message_param, 2, "int as byte overflow"); } # -ve Int $myobject->ScalarByte(-7); is($object->get_last_message_signature, "y", "-ve int as byte"); SKIP: { skip "byte sign truncation not double checked", 1; is($object->get_last_message_param, 2, "-ve int as byte"); } # -ve Double roudning $myobject->ScalarByte(-2.6); is($object->get_last_message_signature, "y", "double as byte"); SKIP: { skip "byte sign truncation not double checked", 1; is($object->get_last_message_param, 2, "-ve double as byte"); } # -ve Range overflow $myobject->ScalarByte(-10000); is($object->get_last_message_signature, "y", "-ve int as byte overflow"); SKIP: { skip "byte sign truncation not double checked", 1; is($object->get_last_message_param, 2, "-ve int as byte overflow"); } ##### Boolean # String, O and false $myobject->ScalarBoolean("0"); is($object->get_last_message_signature, "b", "string as boolean, 0 and false"); is($object->get_last_message_param, '', "string as boolean, 0 and false"); # String, O but true $myobject->ScalarBoolean("0true"); is($object->get_last_message_signature, "b", "string as boolean, 0 but true"); is($object->get_last_message_param, 1, "string as boolean, 0 but true"); # String, 1 and true $myobject->ScalarBoolean("1true"); is($object->get_last_message_signature, "b", "string as boolean, 1 and true"); is($object->get_last_message_param, 1, "string as boolean, 1 and true"); # Int true $myobject->ScalarBoolean(1); is($object->get_last_message_signature, "b", "int as boolean, true"); is($object->get_last_message_param, 1, "int as boolean, true"); # Int false $myobject->ScalarBoolean(0); is($object->get_last_message_signature, "b", "int as boolean, false"); is($object->get_last_message_param, '', "int as boolean, false"); # Undefined and false $myobject->ScalarBoolean(undef); is($object->get_last_message_signature, "b", "undefined as boolean, false"); is($object->get_last_message_param, '', "undefined as boolean, false"); } exit 0; sub setup { my $bus = Net::DBus->test; my $service = $bus->export_service("org.cpan.Net.Bus.test"); my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject"); my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); my $robject = $rservice->get_object("/org/example/MyObject"); my $myobject = $robject->as_interface("org.example.MyObject"); my $otherobject = $robject->as_interface("org.example.OtherObject"); $object->seed_action("org.example.MyObject", "ScalarString", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarInt16", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarUInt16", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarInt32", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarUInt32", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarDouble", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarByte", reply => { return => [] }); $object->seed_action("org.example.MyObject", "ScalarBoolean", reply => { return => [] }); return ($bus, $object, $robject, $myobject, $otherobject); } Net-DBus-1.0.0/t/20-callback.t0000644000076500007650000000174511603165524015654 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 5; use strict; use warnings; BEGIN { use_ok('Net::DBus::Callback'); }; my $doneit = 0; my $doer = Doer->new; my $callback = Net::DBus::Callback->new( object => $doer, method => "doit", args => [4, 3, 5] ); $callback->invoke(); ok($doer->doneit == 12, "object callback"); $callback->invoke(); ok($doer->doneit == 24, "object callback"); $callback = Net::DBus::Callback->new( method => \&doit, args => [5,1,2] ); $callback->invoke(); ok($doneit == 8, "subroutine callback"); $callback->invoke(); ok($doneit == 16, "subroutine callback"); sub doit { foreach (@_) { $doneit += $_; } } package Doer; sub new { my $class = shift; my $self = {}; $self->{doneit} = 0; bless $self, $class; return $self; } sub doit { my $self = shift; foreach (@_) { $self->{doneit} += $_; } } sub doneit { my $self = shift; return $self->{doneit}; } Net-DBus-1.0.0/t/60-object-props.t0000644000076500007650000002203611603165524016527 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 18; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); use_ok('Net::DBus::Object'); }; package MyObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.example.MyObject); # Typically one would use Class::MethodMaker, but I don't # want to add a hard dependancy for the test suite. #use Class::MethodMaker [ scalar => ["name", "email", "age" ]]; sub name { my $self = shift; $self->{name} = shift if @_; return $self->{name}; } sub email { my $self = shift; $self->{email} = shift if @_; return $self->{email}; } sub age { my $self = shift; $self->{age} = shift if @_; return $self->{age}; } sub parents { my $self = shift; $self->{parents} = shift if @_; return $self->{parents}; } sub height { my $self = shift; $self->{height} = shift if @_; return $self->{height}; } dbus_property("name", "string"); dbus_property("email", "string", "read"); dbus_property("age", "int32" ,"write"); dbus_property("parents", ["array", "string"]); dbus_property("height", "double", "write"); package main; use Net::DBus qw(:typing); my $bus = Net::DBus->test; my $service = $bus->export_service("org.cpan.Net.Bus.test"); my $object = MyObject->new($service, "/org/example/MyObject"); my $introspector = $object->_introspector; my $xml_got = $introspector->format($object); my $xml_expect = < EOF is($xml_got, $xml_expect, "xml data matches"); GET_NAME: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Get"); my $iter = $msg->iterator(1); $iter->append_string("org.example.MyObject"); $iter->append_string("name"); $object->name("John Doe"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my ($value) = $reply->get_args_list; is($value, "John Doe", "name is John Doe"); } GET_BOGUS: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Get"); my $iter = $msg->iterator(1); $iter->append_string("org.example.MyObject"); $iter->append_string("bogus"); $object->name("John Doe"); my $reply = eval { $bus->get_connection->send_with_reply_and_block($msg); }; ok($@, "error is set"); } sub GET_SET_NAME: { my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Get"); my $iter1 = $msg1->iterator(1); $iter1->append_string("org.example.MyObject"); $iter1->append_string("name"); $object->name("John Doe"); my $reply1 = $bus->get_connection->send_with_reply_and_block($msg1); is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my ($value1) = $reply1->get_args_list; is($value1, "John Doe", "name is John Doe"); my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Set"); my $iter2 = $msg2->iterator(1); $iter2->append_string("org.example.MyObject"); $iter2->append_string("name"); $iter2->append_variant("Jane Doe"); my $reply2 = $bus->get_connection->send_with_reply_and_block($msg2); is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my $reply3 = $bus->get_connection->send_with_reply_and_block($msg1); is($reply3->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my ($value2) = $reply3->get_args_list; is($value2, "Jane Doe", "name is Jane Doe"); } SET_AGE: { my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Get"); my $iter1 = $msg1->iterator(1); $iter1->append_string("org.example.MyObject"); $iter1->append_string("age"); my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Set"); my $iter2 = $msg2->iterator(1); $iter2->append_string("org.example.MyObject"); $iter2->append_string("age"); $iter2->append_variant(21); my $reply1 = $bus->get_connection->send_with_reply_and_block($msg2); is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my $reply2 = eval { $bus->get_connection->send_with_reply_and_block($msg1); }; ok($@, "error is set"); is($object->age, 21, "age is 21"); } GET_EMAIL: { my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Get"); my $iter1 = $msg1->iterator(1); $iter1->append_string("org.example.MyObject"); $iter1->append_string("email"); $object->email('john@example.com'); my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "Set"); my $iter2 = $msg2->iterator(1); $iter2->append_string("org.example.MyObject"); $iter2->append_string("email"); $iter2->append_variant('jane@example.com'); my $reply1 = eval { $bus->get_connection->send_with_reply_and_block($msg2); }; ok($@, "error is set"); my $reply2 = $bus->get_connection->send_with_reply_and_block($msg1); is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); is($object->age, 21, "age is 21"); my ($value) = $reply2->get_args_list; is($value, 'john@example.com', 'email is john@example.com'); } SET_HEIGHT: { my $msg = $bus->get_connection()->make_method_call_message("org.example.MyService", "/org/example/MyObject", "org.freedesktop.DBus.Properties", "Set"); $introspector->encode($msg, "methods", "Set", "params", "org.example.MyObject", "height", dbus_double(1.414)); is($msg->get_signature, "ssv", "signature is ssvd"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); ok($object->height > 1.410 && $object->height < 1.420, "height is 1.414"); } GET_ALL: { my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", object_path => "/org/example/MyObject", interface => "org.freedesktop.DBus.Properties", method_name => "GetAll"); my $iter = $msg->iterator(1); $iter->append_string("org.example.MyObject"); $iter->append_string("name"); my $reply = $bus->get_connection->send_with_reply_and_block($msg); is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); my ($value) = $reply->get_args_list; # we use sort because there is no strict order of keys(...) call result is_deeply([sort(keys(%$value))], [sort("name", "email", "parents")], "all readable properties have been received"); } Net-DBus-1.0.0/t/66-child-objects.t0000644000076500007650000001143611603165524016642 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 5; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); use_ok('Net::DBus::Object'); }; package ObjectType1; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(com.dbelser.test.type1); sub new { my $class = shift; my $service = shift; my $path = shift; my $name = shift; my $self = $class->SUPER::new($service, "$path"); bless $self, $class; $self->{name} = $name; return $self; } dbus_method("version", [], ["string"], { arg_names=>["version"],} ); sub version { my $self = shift; return ("$self->{name}: ObjectType1, Version 0.1"); } package ObjectType2; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(com.dbelser.test.type2); sub new { my $class = shift; my $service = shift; my $path = shift; my $name = shift; my $self = $class->SUPER::new($service, "$path"); bless $self, $class; $self->{name} = $name; return $self; } dbus_method("version", [], ["string"], { arg_names=>["version"],} ); sub version { my $self = shift; return ("$self->{name}: ObjectType2, Version 0.1"); } package ObjectType3; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(com.dbelser.test.type3); sub new { my $class = shift; my $service = shift; my $path = shift; my $name = shift; my $self = $class->SUPER::new($service, "$path"); bless $self, $class; $self->{name} = $name; return $self; } dbus_method("version", [], ["string"], { arg_names=>["version"],} ); sub version { my $self = shift; return ("$self->{name}: ObjectType3, Version 0.1"); } package main; use Net::DBus qw(:typing); my $bus = Net::DBus->test; my $service = $bus->export_service("org.cpan.Net.Bus.test"); # base path for this app my $base = "/base"; my $root = ObjectType1->new($service,$base,"Root"); # second tier one each my $c1 = ObjectType1->new($root,"/branch_1", "C1"); my $c2 = ObjectType2->new($root,"/branch_2", "C2"); my $c3 = ObjectType3->new($root,"/branch_3", "C3"); # go deep my $c4 = ObjectType1->new($c1,"/one", "C4"); my $c5 = ObjectType2->new($c4,"/two", "C5"); my $c6 = ObjectType3->new($c5,"/three", "C6"); # skip some nodes my $c7 = ObjectType1->new($c2,"/skip/one", "C7"); my $c8 = ObjectType2->new($c7,"/skip/skip/two", "C8"); my $c9 = ObjectType3->new($c8,"/skip/skip/skip/three", "C9"); my $introspector = $root->_introspector; my $xml_got = $introspector->format($root); my $xml_expect = < EOF is($xml_got, $xml_expect, "xml data matches"); my $ins2 = Net::DBus::Binding::Introspector->new(xml => $xml_got); my @children = $ins2->list_children(); is_deeply(\@children, ["/branch_1", "/branch_2", "/branch_3"], "children match"); $introspector = $c2->_introspector; $xml_got = $introspector->format($c2); $xml_expect = < EOF is($xml_got, $xml_expect, "xml data matches"); Net-DBus-1.0.0/t/55-method-calls.t0000644000076500007650000001476711603165524016514 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 56; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector') or die; use_ok('Net::DBus::Object') or die; use_ok('Net::DBus::Test::MockObject') or die; }; TEST_NO_INTROSPECT: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", error => { name => "org.freedesktop.DBus.Error.Failed", description => "No such method" }); &test_method_fail("raw, no introspect", $robject, "Test"); &test_method_reply("myobject, no introspect",$myobject, "Test", "TestedMyObject"); &test_method_fail("otherobject, no introspect",$otherobject, "Test"); &test_method_fail("raw, no introspect",$robject, "Bogus"); &test_method_fail("myobject, no introspect",$myobject, "Bogus"); &test_method_fail("otherobject, no introspect",$otherobject, "Bogus"); &test_method_fail("raw, no introspect",$robject, "PolyTest"); &test_method_reply("myobject, no introspect",$myobject, "PolyTest", "PolyTestedMyObject"); &test_method_reply("otherobject, no introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); &test_method_fail("raw, no introspect", $robject, "Deprecated"); &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); } TEST_MISSING_INTROSPECT: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", reply => { return => [ $ins->format ] }); &test_method_fail("raw, missing introspect",$robject, "Test"); &test_method_reply("myobject, missing introspect",$myobject, "Test", "TestedMyObject"); &test_method_fail("otherobject, missing introspect",$otherobject, "Test"); &test_method_fail("raw, missing introspect",$robject, "Bogus"); &test_method_fail("myobject, missing introspect",$myobject, "Bogus"); &test_method_fail("otherobject, missing introspect",$otherobject, "Bogus"); &test_method_fail("raw, missing introspect",$robject, "PolyTest"); &test_method_reply("myobject, missing introspect",$myobject, "PolyTest", "PolyTestedMyObject"); &test_method_reply("otherobject, missing introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); &test_method_fail("raw, no introspect", $robject, "Deprecated"); &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); } TEST_FULL_INTROSPECT: { my ($bus, $object, $robject, $myobject, $otherobject) = &setup; my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); $ins->add_method("Test", [], ["string"], "org.example.MyObject", {}, []); $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject", {}, []); $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject", {}, []); $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 }, []); $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", reply => { return => [ $ins->format ] }); &test_method_reply("raw, full introspect",$robject, "Test", "TestedMyObject"); &test_method_reply("myobject, full introspect",$myobject, "Test", "TestedMyObject"); &test_method_fail("otherobject, full introspect",$otherobject, "Test"); &test_method_fail("raw, full introspect",$robject, "Bogus"); &test_method_fail("myobject, full introspect",$myobject, "Bogus"); &test_method_fail("otherobject, full introspect",$otherobject, "Bogus"); &test_method_fail("raw, full introspect",$robject, "PolyTest"); &test_method_reply("myobject, full introspect",$myobject, "PolyTest", "PolyTestedMyObject"); &test_method_reply("otherobject, full introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); { my $warned = 0; local $SIG{__WARN__} = sub { if ($_[0] eq "method 'Deprecated' in interface org.example.MyObject on object /org/example/MyObject is deprecated\n") { $warned = 1; } }; &test_method_reply("raw, no introspect", $robject, "Deprecated", "TestedDeprecation"); ok($warned, "deprecation warning generated"); $warned = 0; &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); ok($warned, "deprecation warning generated"); $warned = 0; &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); ok(!$warned, "deprecation warning generated"); } } sub setup { my $bus = Net::DBus->test; my $service = $bus->export_service("org.cpan.Net.Bus.test"); my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject"); my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); my $robject = $rservice->get_object("/org/example/MyObject"); my $myobject = $robject->as_interface("org.example.MyObject"); my $otherobject = $robject->as_interface("org.example.OtherObject"); $object->seed_action("org.example.MyObject", "Test", reply => { return => [ "TestedMyObject" ] }); $object->seed_action("org.example.MyObject", "PolyTest", reply => { return => [ "PolyTestedMyObject" ] }); $object->seed_action("org.example.OtherObject", "PolyTest", reply => { return => [ "PolyTestedOtherObject" ] }); $object->seed_action("org.example.MyObject", "Deprecated", reply => { return => [ "TestedDeprecation" ]}); $object->seed_action("org.example.MyObject", "TestNoReturn"); return ($bus, $object, $robject, $myobject, $otherobject); } sub test_method_noreply { my $tag = shift; my $object = shift; my $method = shift; my $actual = eval { $object->$method; }; is($@, "", "error is not thrown by '$method' ($tag)"); ok(!$actual, "return from '$method' is undefined ($tag)"); } sub test_method_reply { my $tag = shift; my $object = shift; my $method = shift; my $expect = shift; my $actual = eval { $object->$method; }; is($@, "", "error is not thrown by '$method' ($tag)"); is($actual, $expect, "return from '$method' is '$actual' ($tag)"); } sub test_method_fail { my $tag = shift; my $object = shift; my $method = shift; my $actual = eval { $object->$method; }; ok($@, "error is thrown by '$method' ($tag)"); } Net-DBus-1.0.0/t/40-introspector.t0000644000076500007650000001400511603165524016646 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 6; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); }; TEST_ONE: { my $other_object = Net::DBus::Binding::Introspector->new( object_path => "org.example.Object.OtherObject", interfaces => { "org.example.SomeInterface" => { methods => { "hello" => { params => ["int32", "int32", ["struct", "int32","byte"]], returns => ["int32"], paramnames => ["wibble", "eek"], returnnames => ["frob"], }, "goodbye" => { params => [["array", ["struct", "int32", "string"]]], returns => ["string", "string"], paramnames => ["ooh"], returnnames => ["ahh", "eek"], }, }, signals => { "meltdown" => { params => ["int32", "byte"], } }, props => { "name" => { type => "string", access => "readwrite"}, "email" => { type => "string", access => "read"}, "age" => { type => "int32", access => "read"}, "parents" => { type => ["array", "string"], access => "readwrite" }, }, } }); isa_ok($other_object, "Net::DBus::Binding::Introspector"); my $other_xml_got = $other_object->format(); my $other_xml_expect = < EOF is($other_xml_got, $other_xml_expect, "xml data matches"); my $object = Net::DBus::Binding::Introspector->new( object_path => "org.example.Object", interfaces => { "org.example.SomeInterface" => { methods => { "hello" => { params => ["int32", "int32", ["struct", "int32","byte"]], returns => ["uint32"], paramnames => [], returnnames => [], }, "goodbye" => { params => [["array", ["dict", "int32", "string"]]], returns => ["string", ["array", "string"]], paramnames => [], returnnames => [], }, }, signals => { "meltdown" => { params => ["int32", "byte"], paramnames => [], } }, }, "org.example.OtherInterface" => { methods => { "hitme" => { params => ["int32", "uint32"], return => [], paramnames => [], returnnames => [], } }, props => { "title" => { type => "string", access => "readwrite"}, "salary" => { type => "int32", access => "read"}, }, }, }, children => [ "org.example.Object.SubObject", $other_object, ]); isa_ok($object, "Net::DBus::Binding::Introspector"); my $object_xml_got = $object->format(); my $object_xml_expect = < EOF is($object_xml_got, $object_xml_expect, "xml data matches"); my $recon_other = Net::DBus::Binding::Introspector->new(xml => $object_xml_got); my $object_xml_got_again = $recon_other->format(); is($object_xml_got_again, $object_xml_expect, "reconstructed xml matches"); } Net-DBus-1.0.0/t/42-object-introspect-avahi.t0000644000076500007650000000566211603165524020652 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 10; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); }; local $/ = undef; my $xml = ; my $introspector = Net::DBus::Binding::Introspector->new(object_path => "/org/freedesktop/Avahi/ServiceBrowser", xml => $xml); isa_ok($introspector, "Net::DBus::Binding::Introspector"); ok($introspector->has_interface("org.freedesktop.DBus.Introspectable"), "org.freedesktop.DBus.Introspectable interface present"); ok($introspector->has_interface("org.freedesktop.Avahi.ServiceBrowser"), "org.freedesktop.Avahi.ServiceBrowser interface present"); ok($introspector->has_method("Free"), "Free method present"); ok($introspector->has_signal("ItemNew"), "ItemNew signal present"); ok($introspector->has_signal("ItemRemove"), "ItemRemove signal present"); ok($introspector->has_signal("Failure"), "Failure signal present"); ok($introspector->has_signal("AllForNow"), "AllForNow signal present"); ok($introspector->has_signal("CacheExhausted"), "CacheExhausted signal present"); __DATA__ Net-DBus-1.0.0/t/50-object-introspect.t0000644000076500007650000000252411603165524017555 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 3; use strict; use warnings; BEGIN { use_ok('Net::DBus::Binding::Introspector'); use_ok('Net::DBus::Object'); }; my $bus = Net::DBus->test; my $service = $bus->export_service("/org/cpan/Net/DBus/Test/introspect"); my $object = Net::DBus::Object->new($service, "/org/example/Object/OtherObject"); my $introspector = $object->_introspector; my $xml_got = $introspector->format($object); my $xml_expect = < EOF is($xml_got, $xml_expect, "xml data matches"); Net-DBus-1.0.0/t/00-constants.t0000644000076500007650000000206411603165524016125 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 6; BEGIN { use_ok('Net::DBus::Binding::Watch'); use_ok('Net::DBus::Binding::Message'); use_ok('Net::DBus::Binding::Bus'); }; my $fail = 0; foreach my $constname (qw( SYSTEM SESSION STARTER)) { next if (eval "my \$a = &Net::DBus::Binding::Bus::$constname; 1"); print "# fail: $@"; $fail = 1; } ok( $fail == 0 , 'Net::DBus::Binding::Bus Constants' ); $fail = 0; foreach my $constname (qw( TYPE_ARRAY TYPE_BOOLEAN TYPE_BYTE TYPE_DOUBLE TYPE_STRUCT TYPE_INT32 TYPE_INT64 TYPE_DICT_ENTRY TYPE_INVALID TYPE_SIGNATURE TYPE_OBJECT_PATH TYPE_STRING TYPE_UINT32 TYPE_UINT64)) { next if (eval "my \$a = &Net::DBus::Binding::Message::$constname; 1"); print "# fail: $@"; $fail = 1; } ok( $fail == 0 , 'Net::DBus::Binding::Message Constants' ); $fail = 0; foreach my $constname (qw( READABLE WRITABLE ERROR HANGUP)) { next if (eval "my \$a = &Net::DBus::Binding::Watch::$constname; 1"); print "# fail: $@"; $fail = 1; } ok( $fail == 0 , 'Net::DBus::Binding::Watch Constants' ); Net-DBus-1.0.0/t/25-reactor.t0000644000076500007650000000435211603165524015561 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 16; use POSIX qw(pipe read write); use strict; use warnings; # The tests for timeouts will only work # reliably on unloaded machine BEGIN { use_ok('Net::DBus::Reactor'); use_ok('Net::DBus::Callback'); }; my $reactor = Net::DBus::Reactor->new(); my $started = $reactor->_now; my $fired; my $alarmed; my $tid = $reactor->add_timeout(2000, Net::DBus::Callback->new(method => \&timeout, args => []), 1); $SIG{ALRM} = sub { $alarmed = 1 }; # Alarm just in case something goes horribly wrong alarm 5; $reactor->run; alarm 0; ok (!$alarmed, "not alarmed"); ok (defined $fired, "timeout fired"); # Timing is tricky, so just check a reasonble range ok(($fired-$started) > 1900 && ($fired-$started) < 3000, "timeout in range 1900->3000"); sub timeout { $fired = $reactor->_now; $reactor->shutdown; } $reactor->remove_timeout($tid); my ($r1, $w1) = pipe; my ($r2, $w2) = pipe; write $w1, "1", 1; my ($r1c, $w1c, $r2c, $w2c) = (0,0,0,0); my $hookc = 0; $reactor->add_read($r1, Net::DBus::Callback->new(method => \&do_r1)); $reactor->add_write($w1, Net::DBus::Callback->new(method => \&do_w1), 0); $reactor->add_read($r2, Net::DBus::Callback->new(method => \&do_r2)); $reactor->add_write($w2, Net::DBus::Callback->new(method => \&do_w2), 0); $reactor->add_hook(Net::DBus::Callback->new(method => \&hook)); $reactor->{running} = 1; $reactor->step; ok($r1c == 1, "read one byte a"); ok($r2c == 0, "not read one byte b"); ok($hookc == 1, "hook 1\n"); write $w1, "11", 2; write $w2, "1", 1; $reactor->{running} = 1; $reactor->step; ok($r1c == 2, "read 2 byte a"); ok($r2c == 1, "read one byte b"); ok($hookc == 2, "hook 2\n"); $reactor->{running} = 1; $reactor->step; ok($r1c == 3, "read 2 byte a"); ok($hookc == 3, "hook 3\n"); $reactor->toggle_write($w1, 1); $reactor->toggle_write($w2, 1); $reactor->{running} = 1; $reactor->step; ok($w1c == 1, "write 1 byte a"); ok($w2c == 1, "write 1 byte b"); ok($hookc == 4, "hook 4\n"); sub do_r1 { my $buf; $r1c += read $r1, $buf, 1; } sub do_w1 { $w1c += write $w1, "1", 1; } sub do_r2 { my $buf; $r2c += read $r2, $buf, 1; } sub do_w2 { $w2c += write $w2, "1", 1; } sub hook { $hookc++; } Net-DBus-1.0.0/t/70-errors.t0000644000076500007650000000235611603165524015440 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 6; use strict; use warnings; BEGIN { use_ok('Net::DBus'); use_ok('Net::DBus::Error'); use_ok('Net::DBus::Object'); }; package MyError; use base qw(Net::DBus::Error); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->SUPER::new(name => "org.example.music.UnknownFormat", message => "Unknown track encoding format"); } package MyObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.example.MyObject); dbus_method("play", ["string"], ["string"]); sub play { my $self = shift; my $url = shift; if ($url =~ /\.(mp3|ogg)$/) { return $url; } else { die MyError->new(); } } package main; my $bus = Net::DBus->test; my $service = $bus->export_service("org.cpan.Net.Bus.test"); my $object = MyObject->new($service, "/org/example/MyObject"); my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); my $robject = $rservice->get_object("/org/example/MyObject"); eval { $robject->play("foo.flac"); }; my $error = $@; isa_ok($error, "Net::DBus::Error"); is($error->name, "org.example.music.UnknownFormat", "error name is set"); is($error->message, "Unknown track encoding format", "error description is set"); Net-DBus-1.0.0/t/45-exporter.t0000644000076500007650000002110211603165524015764 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 94; use strict; use warnings; package MyObject1; use strict; use warnings; use Test::More; use base qw(Net::DBus::Object); use Net::DBus; use Net::DBus::Service; use Net::DBus::Exporter qw(org.example.MyObject); my $bus = Net::DBus->test; my $service = $bus->export_service("org.example.MyService"); my $obj = MyObject1->new($service, "/org/example/MyObject"); # First the full APIs dbus_method("Everything", ["string"], ["int32"]); dbus_method("EverythingInterface", ["string"], ["int32"], "org.example.OtherObject"); # Now add in annotations to the mix dbus_method("EverythingAnnotate", ["string"], ["int32"], { deprecated => 1, no_return => 1 }); dbus_method("EverythingNegativeAnnotate", ["string"], ["int32"], { deprecated => 0, no_return => 0 }); dbus_method("EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 1, no_return => 1 }); dbus_method("EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 0, no_return => 0 }); # Now test 'defaults' dbus_method("NoArgsReturns"); dbus_method("NoReturns", ["string"], [], { param_names => ["wizz"] }); dbus_method("NoArgs",[],["int32"]); dbus_method("NoArgsReturnsInterface", "org.example.OtherObject"); dbus_method("NoReturnsInterface", ["string"], "org.example.OtherObject"); dbus_method("NoArgsInterface", [],["int32"], "org.example.OtherObject"); dbus_method("NoArgsReturnsAnnotate", { deprecated => 1 }); dbus_method("NoReturnsAnnotate", ["string"], { deprecated => 1 }); dbus_method("NoArgsAnnotate",[],["int32"], { deprecated => 1 }); dbus_method("NoArgsReturnsInterfaceAnnotate", "org.example.OtherObject", { deprecated => 1 }); dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1, param_names => ["one"] }); dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject", { deprecated => 1, return_names => ["two"] }); dbus_method("DemoInterfaceName1", [], ["string"], "_org.example._some_9object"); eval { dbus_method("DemoInterfaceName2", [], ["string"], "9org.example.SomeObject"); }; ok($@ ne "", "raised error for leading digit in interface"); my $ins = Net::DBus::Exporter::_dbus_introspector(ref($obj)); ok($ins->has_interface("org.example.MyObject"), "interface registration"); ok(!$ins->has_interface("org.example.BogusObject"), "-ve interface registration"); my $wantxml = < EOF is ($ins->format($obj), $wantxml, "xml matches"); &check_method($ins, "Everything", ["string"], ["int32"], "org.example.MyObject", 0, 0); &check_method($ins, "EverythingInterface", ["string"], ["int32"], "org.example.OtherObject", 0, 0); &check_method($ins, "EverythingAnnotate", ["string"], ["int32"], "org.example.MyObject", 1, 1); &check_method($ins, "EverythingNegativeAnnotate", ["string"], ["int32"], "org.example.MyObject", 0, 0); &check_method($ins, "EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", 1, 1); &check_method($ins, "EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", 0, 0); &check_method($ins, "NoArgsReturns", [], [], "org.example.MyObject", 0, 0); &check_method($ins, "NoReturns", ["string"], [], "org.example.MyObject", 0, 0); &check_method($ins, "NoArgs", [], ["int32"], "org.example.MyObject", 0, 0); &check_method($ins, "NoArgsReturnsInterface", [], [], "org.example.OtherObject", 0, 0); &check_method($ins, "NoReturnsInterface", ["string"], [], "org.example.OtherObject", 0, 0); &check_method($ins, "NoArgsInterface", [], ["int32"], "org.example.OtherObject", 0, 0); &check_method($ins, "NoArgsReturnsAnnotate", [], [], "org.example.MyObject", 1, 0); &check_method($ins, "NoReturnsAnnotate", ["string"], [], "org.example.MyObject", 1, 0); &check_method($ins, "NoArgsAnnotate", [], ["int32"], "org.example.MyObject", 1, 0); &check_method($ins, "NoArgsReturnsInterfaceAnnotate", [], [], "org.example.OtherObject", 1, 0); &check_method($ins, "NoReturnsInterfaceAnnotate", ["string"], [], "org.example.OtherObject", 1, 0); &check_method($ins, "NoArgsInterfaceAnnotate", [], ["int32"], "org.example.OtherObject", 1, 0); sub check_method { my $ins = shift; my $name = shift; my $params = shift; my $returns = shift; my $interface = shift; my $deprecated = shift; my $no_return = shift; my @interfaces = $ins->has_method($name); is_deeply([$interface], \@interfaces, "method interface mapping"); my @params = $ins->get_method_params($interface, $name); is_deeply($params, \@params, "method parameters"); my @returns = $ins->get_method_returns($interface, $name); is_deeply($returns, \@returns, "method returneters"); if ($deprecated) { ok($ins->is_method_deprecated($name, $interface), "method deprecated"); } else { ok(!$ins->is_method_deprecated($name, $interface), "method deprecated"); } if ($no_return) { ok(!$ins->does_method_reply($name, $interface), "method no reply"); } else { ok($ins->does_method_reply($name, $interface), "method no reply"); } } Net-DBus-1.0.0/t/75-notifications.t0000644000076500007650000000376111603165524017003 0ustar berrangeberrange# -*- perl -*- use Test::More tests => 10; # This test case is primarily about variants - but # in particular the signature of org.freedesktop.Notifications.Notify use strict; use warnings; BEGIN { use_ok('Net::DBus') or die; use_ok('Net::DBus::Object') or die; }; package MyObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.cpan.Net.DBus.Test.Notify); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/org/cpan/Net/DBus/Test/Notify"); bless $self, $class; $self->{data} = {}; return $self; } dbus_method("Notify", ["string", "uint32", "string", "string", "string", ["array", "string"], [ "dict", "string", ["variant"]], "int32"],["uint32"]); sub Notify { my $self = shift; $self->{data} = \@_; return 0; } package main; my $bus = Net::DBus->test; my $svc = $bus->export_service("org.cpan.Net.DBus.Test.Notify"); my $obj = MyObject->new($svc); my $rsvc = $bus->get_service("org.cpan.Net.DBus.Test.Notify"); my $robj = $rsvc->get_object("/org/cpan/Net/DBus/Test/Notify"); my $res = $robj->Notify( "dbus-test", # Application name 7, # replaces_id (0 -> nothing) 'someicon', #app_icon ("" -> no icon) 'Test event', # summary "This is a test to see if DBUS works nicely in Perl.\nI hope that this works.", # body ["frob", "wibble"], # actions {"ooh" => "eek", "bar" => "wizz"}, # hints 2_000 # expire_timeout in milliseconds ); is($obj->{data}->[0], "dbus-test", "name is correct"); is($obj->{data}->[1], 7, "replacesid is correct"); is($obj->{data}->[2], "someicon", "icon is correct"); is($obj->{data}->[3], "Test event", "summary is correct"); is($obj->{data}->[4], "This is a test to see if DBUS works nicely in Perl.\nI hope that this works.", "name is correct"); is_deeply($obj->{data}->[5], ["frob", "wibble"], "actions is correct"); is_deeply($obj->{data}->[6], {"ooh" => "eek", "bar" => "wizz"}, "hints is correct"); is($obj->{data}->[7], 2_000, "timeout is correct"); Net-DBus-1.0.0/Makefile.PL0000644000076500007650000000236211603165524015217 0ustar berrangeberrangeuse 5.006; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my $DBUS_LIBS = `pkg-config --libs dbus-1`; my $DBUS_CFLAGS = `pkg-config --cflags dbus-1`; if (!defined $DBUS_LIBS || !defined DBUS_CFLAGS) { die "could not run 'pkg-config' to determine compiler/linker flags for dbus library: $!\n"; } if (!$DBUS_LIBS || !$DBUS_CFLAGS) { die "'pkg-config' didn't report any compiler/linker flags for dbus library\n"; } my $wall = ""; if ($^O eq "linux") { $wall = "-Wall"; } WriteMakefile( 'NAME' => 'Net::DBus', 'VERSION_FROM' => 'lib/Net/DBus.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'Time::HiRes' => 0, 'XML::Twig' => 0, }, 'AUTHOR' => 'Daniel Berrange ', 'LIBS' => [$DBUS_LIBS], 'DEFINE' => ("-DNET_DBUS_DEBUG=1"), 'INC' => "$wall $DBUS_CFLAGS", 'NO_META' => 1, 'depend' => { Net-DBus.spec => '$(VERSION_FROM)', Makefile => '$(VERSION_FROM)', }, 'realclean' => { FILES => 'Net-DBus.spec', }, ); package MY; sub libscan { my ($self, $path) = @_; ($path =~ /\~$/ || $path =~ m,/CVS/,) ? undef : $path; } __END__ Net-DBus-1.0.0/AUTHORS0000644000076500007650000000117011603165524014311 0ustar berrangeberrange Net::DBus - Perl APIs for DBus ============================== Net::DBus is written by Daniel Berrange With patches, contributions & suggestions gratefully received from Carlos Garnacho Emmanuele Bassi Olivier Blin Jack Dave Belser Stefan Pfetzing Pavel Strashkin Mathieu Bridon [...send patches to get your name here!] -- End Net-DBus-1.0.0/README0000644000076500007650000000665411603165524014135 0ustar berrangeberrange Net::DBus ========= Net::DBus provides a Perl XS API to the dbus inter-application messaging system. The Perl API covers the core base level of the dbus APIs, not concerning itself yet with the GLib or QT wrappers. For more information on dbus visit the project website at: http://www.freedesktop.org/software/dbus/ This version operates against DBus 1.00, and later INSTALLATION ------------ To install this module type the following: perl Makefile.PL make make test sudo make install The makefile calls the C script to determine the correct flags to pass to the compiler & linkers when building the XS part of the module. Thus, ensure pkg-config is in a directory listed by the $PATH environment. The pkg-config program will likely find the DBus install in /usr provided by the base OS distribution, so if testing against an alternate install of DBus, set the C$PKG_CONFIG_PATH env variable before generating the Makefile. For example, if your dbus installation is in C<$HOME/usr/dbus-cvs-tip> , then to build and install against this version of DBus do export PKG_CONFIG_PATH=$HOME/usr/dbus-cvs-tip/lib/pkg-config perl Makefile.PL PREFIX=$HOME/usr/dbus-cvs-tip make make test make install DEPENDENCIES ------------ In keeping with the C API, the Perl DBus implementation has minimal external dependancies: Time::HiRes XML::Twig XML::Parser And to run the test suite: Test::More Test::Pod (optional, but recommended) Test::Pod::Coverage (optional, but recommended) Although they are not part of the base Perl distribution, most OS distributor will already provide addon packages containing these modules. Failing this, they are all available from CPAN http://search.cpan.org/ EXAMPLES -------- There are a number of example programs in the examples/ subdirectory demonstrating use of the high level application developer APIs. example-service.pl - Providing a simple service example-client.pl - Talking to a remote service example-signal-emitter.pl - How to broadcast signals example-signal-receiver.pl - How to receive signals dump-object.pl - Dump info about dbus objects lshal.pl - Dump names of all HAL devices CONTRIBUTIONS ------------- Contributions both simple bug fixes & new features are always welcome. Please supply patches in context, or unified diff format. A simple method to generate such a patch is as follows: * Clean out generated files from your working directory: make distclean * Rename your working directory to have '-new' extension: mv DBus-1.0.0 DBus-1.0.0-new * Extract a pristine copy of the source: gunzip -c DBus-1.0.0.tar.gz | tar xf - mv DBus-1.0.0 DBus-1.0.0-orig * Generate the patch: diff -ruN DBus-1.0.0-orig DBus-1.0.0-new \ > DBus-1.0.0-[something].patch gzip DBus-1.0.0-[something].patch Send the resulting to .patch.gz file directly to Daniel Berrange COPYRIGHT AND LICENCE --------------------- Copyright (C) 2004-2011 Daniel Berrange Net-DBus may be redistributed and/or modified under the terms of Perl itself. Either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version or b) the "Artistic License" See the file "COPYING" for the full text of each license -- End Net-DBus-1.0.0/examples/0000755000076500007650000000000011603165554015063 5ustar berrangeberrangeNet-DBus-1.0.0/examples/example-client-async.pl0000644000076500007650000000137111603165524021441 0ustar berrangeberrange#/usr/bin/perl use warnings; use strict; use Net::DBus; use Net::DBus::Reactor; use Net::DBus::Annotation qw(:call); my $bus = Net::DBus->session(); my $service = $bus->get_service("org.designfu.SampleService"); my $object = $service->get_object("/SomeObject"); print "Doing async call\n"; my $reply = $object->HelloWorld(dbus_call_async, "Hello from example-client.pl!"); my $r = Net::DBus::Reactor->main; sub all_done { my $reply = shift; my $list = $reply->get_result; print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; $r->shutdown; } print "Setting notify\n"; $reply->set_notify(\&all_done); sub tick { print "Tick-tock\n"; } print "Adding timer\n"; $r->add_timeout(500, \&tick); print "Entering main loop\n"; $r->run; Net-DBus-1.0.0/examples/dump-object-xml.pl0000644000076500007650000000061111603165524020422 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Net::DBus; use Net::DBus::Dumper; use Carp qw(confess); $SIG{__DIE__} = sub {confess $_[0] }; my $bus = Net::DBus->find; if (int(@ARGV) != 2) { die "syntax: $0 SERVICE OBJECT"; } my $service = $bus->get_service(shift @ARGV); my $object = $service->get_object(shift @ARGV); my $xml = $object->_introspector->format(); print $xml, "\n"; Net-DBus-1.0.0/examples/example-client-no-introspect.pl0000644000076500007650000000123211603165524023124 0ustar berrangeberrange#/usr/bin/perl use warnings; use strict; use Net::DBus; use Carp qw(cluck carp); #$SIG{__WARN__} = sub { cluck $_[0] }; #$SIG{__DIE__} = sub { carp $_[0] }; my $bus = Net::DBus->session(); my $service = $bus->get_service("org.designfu.SampleService"); my $object = $service->get_object("/SomeObject", "org.designfu.SampleInterface"); my $list = $object->HelloWorld("Hello from example-client.pl!"); print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; my $tuple = $object->GetTuple(); print "(", join(", ", map { "'$_'" } @{$tuple}), ")\n"; my $dict = $object->GetDict(); print "{", join(", ", map { "'$_': '" . $dict->{$_} . "'"} keys %{$dict}), "}\n"; Net-DBus-1.0.0/examples/example-signal-emitter.pl0000644000076500007650000000166511603165524022002 0ustar berrangeberrange#!/usr/bin/perl -w use warnings; use strict; use Net::DBus; use Net::DBus::Reactor; use Net::DBus::Service; use Net::DBus::Object; use Carp qw(confess cluck); #$SIG{__WARN__} = sub { cluck $_[0] }; #$SIG{__DIE__} = sub { confess $_[0] }; package TestObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.designfu.TestService); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/org/designfu/TestService/object"); bless $self, $class; return $self; } dbus_signal("HelloSignal", ["string"]); dbus_method("emitHelloSignal"); sub emitHelloSignal { my $self = shift; print "Got request to send hello signal\n"; return $self->emit_signal("HelloSignal", "Hello"); } package main; my $bus = Net::DBus->session(); my $service = $bus->export_service("org.designfu.TestService"); my $object = TestObject->new($service); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/example-service-no-introspect.pl0000644000076500007650000000176611603165524023322 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Carp qw(confess cluck); use Net::DBus; use Net::DBus::Service; use Net::DBus::Reactor; #... continued at botom package SomeObject; use base qw(Net::DBus::Object); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/SomeObject"); bless $self, $class; return $self; } sub HelloWorld { my $self = shift; my $message = shift; print "Do hello world\n"; print $message, "\n"; return ["Hello", " from example-service.pl"]; } sub GetDict { my $self = shift; print "Do get dict\n"; return {"first" => "Hello Dict", "second" => " from example-service.py"}; } sub GetTuple { my $self = shift; print "Do get tuple\n"; return ["Hello Tuple", " from example-service.py"]; } package main; my $bus = Net::DBus->session(); my $service = $bus->export_service("org.designfu.SampleService"); my $object = SomeObject->new($service); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/example-service-magic.pl0000644000076500007650000000304711603165524021570 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Carp qw(confess cluck); use Net::DBus; use Net::DBus::Service; use Net::DBus::Reactor; #... continued at botom package SomeObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.designfu.SampleInterface); #use Class::MethodMaker [ scalar => [ qw(name email age) ]]; #dbus_property("name", "string"); #dbus_property("email", "string", "read"); #dbus_property("age", "int32", "write"); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/SomeObject"); bless $self, $class; return $self; } dbus_method("HelloWorld", ["string", "caller"], [["array", "string"]]); sub HelloWorld { my $self = shift; my $message = shift; my $caller = shift; print "Do hello world from $caller\n"; print $message, "\n"; return ["Hello", " from example-service.pl"]; } dbus_method("GetDict", ["caller"], [["dict", "string", "string"]]); sub GetDict { my $self = shift; my $caller = shift; print "Do get dict from $caller\n"; return {"first" => "Hello Dict", "second" => " from example-service.pl"}; } dbus_method("GetTuple", ["caller"], [["struct", "string", "string"]]); sub GetTuple { my $self = shift; my $caller = shift; print "Do get tuple from $caller\n"; return ["Hello Tuple", " from example-service.pl"]; } package main; my $bus = Net::DBus->session(); my $service = $bus->export_service("org.designfu.SampleService"); my $object = SomeObject->new($service); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/notification.pl0000644000076500007650000000100411603165524020076 0ustar berrangeberrange#!/usr/bin/perl use Net::DBus qw(:typing); my $bus = Net::DBus->session; my $svc = $bus->get_service("org.freedesktop.Notifications"); my $obj = $svc->get_object("/org/freedesktop/Notifications"); $obj->Notify("notification.pl", 0, '', "Demo notification", "Demonstrating using of desktop\n" . "notifications from Net::DBus\n", ["done", "Done"], {"desktop-entry" => "virt-manager", x => dbus_variant(dbus_int32(200)), y => dbus_variant(dbus_int32(200))}, 2_000); Net-DBus-1.0.0/examples/strict-exports.pl0000644000076500007650000000245211603165524020432 0ustar berrangeberrange#!/usr/bin/perl # -*- perl -*- use strict; use warnings; package MyStrictObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter "org.example.MyObject"; sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{name} = "Joe"; $self->{salary} = 100000; bless $self, $class; return $self; } dbus_method("name", [], ["string"]); sub name { my $self = shift; return $self->{name}; } sub salary { my $self = shift; return $self->{salary}; } package MyFlexibleObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.example.MyObject); dbus_no_strict_exports; sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{name} = "Joe"; $self->{salary} = 100000; bless $self, $class; return $self; } dbus_method("name", [], ["string"]); sub name { my $self = shift; return $self->{name}; } sub salary { my $self = shift; return $self->{salary}; } package main; use Net::DBus; use Net::DBus::Reactor; my $bus = Net::DBus->session; my $service = $bus->export_service("org.cpan.Net.Bus.test"); my $object1 = MyStrictObject->new($service, "/org/example/MyStrictObject"); my $object2 = MyFlexibleObject->new($service, "/org/example/MyFlexibleObject"); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/example-client.pl0000644000076500007650000000146711603165524020334 0ustar berrangeberrange#/usr/bin/perl use warnings; use strict; use Net::DBus; use Carp qw(cluck carp confess); #$SIG{__WARN__} = sub { cluck $_[0] }; #$SIG{__DIE__} = sub { confess "[". $_[0] ."]"}; my $bus = Net::DBus->session(); my $service = $bus->get_service("org.designfu.SampleService"); my $object = $service->get_object("/SomeObject"); my $list = $object->HelloWorld("Hello from example-client.pl!"); print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; my $tuple = $object->GetTuple(); print "(", join(", ", map { "'$_'" } @{$tuple}), ")\n"; my $dict = $object->GetDict(); print "{", join(", ", map { "'$_': '" . $dict->{$_} . "'"} keys %{$dict}), "}\n"; if (0) { $object->name("John Doe"); $object->age(21); #$object->email('john.doe@example.com'); print $object->name, " ", " ", $object->email, "\n"; } Net-DBus-1.0.0/examples/dump-object.pl0000644000076500007650000000064311603165524017631 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Net::DBus; use Net::DBus::Dumper; use Carp qw(confess); $SIG{__DIE__} = sub {confess $_[0] }; my $bus = Net::DBus->find; if (@ARGV) { my $service = $bus->get_service(shift @ARGV); if (@ARGV) { my $object = $service->get_object(shift @ARGV); print dbus_dump($object); } else { print dbus_dump($service); } } else { print dbus_dump($bus); } Net-DBus-1.0.0/examples/example-service-async.pl0000644000076500007650000000242511603165524021624 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Carp qw(confess cluck); use Net::DBus; use Net::DBus::Service; use Net::DBus::Reactor; #... continued at botom package SomeObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.designfu.SampleInterface); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/SomeObject"); bless $self, $class; return $self; } dbus_method("HelloWorld", ["string"], [["array", "string"]]); sub HelloWorld { my $self = shift; my $message = shift; print "Do hello world\n"; print $message, "\n"; sleep 10; return ["Hello", " from example-service-async.pl"]; } dbus_method("GetDict", [], [["dict", "string", "string"]]); sub GetDict { my $self = shift; print "Do get dict\n"; sleep 10; return {"first" => "Hello Dict", "second" => " from example-service.pl"}; } dbus_method("GetTuple", [], [["struct", "string", "string"]]); sub GetTuple { my $self = shift; print "Do get tuple\n"; sleep 10; return ["Hello Tuple", " from example-service.pl"]; } package main; my $bus = Net::DBus->session(); my $service = $bus->export_service("org.designfu.SampleService"); my $object = SomeObject->new($service); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/example-signal-receiver.pl0000644000076500007650000000224011603165524022123 0ustar berrangeberrange#!/usr/bin/perl -w use warnings; use strict; use Net::DBus; use Net::DBus::Reactor; use Carp qw(confess cluck); #$SIG{__WARN__} = sub { cluck $_[0] }; #$SIG{__DIE__} = sub { confess $_[0] }; my $bus = Net::DBus->session(); my $service = $bus->get_service("org.designfu.TestService"); my $object = $service->get_object("/org/designfu/TestService/object", "org.designfu.TestService"); my $sig1; my $sig2; my $sig1ref = \$sig1; my $sig2ref = \$sig2; sub hello_signal_handler1 { my $greeting = shift; print ${$sig1ref} . " Received hello signal with greeting '$greeting'\n"; } sub hello_signal_handler2 { my $greeting = shift; print ${$sig2ref} . " Received hello signal with greeting '$greeting'\n"; $object->disconnect_from_signal("HelloSignal", ${$sig2ref}); ${$sig2ref} = undef; } $sig1 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler1); $sig2 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler2); my $reactor = Net::DBus::Reactor->main(); my $ticks = 0; $reactor->add_timeout(5000, sub { $object->emitHelloSignal(); if ($ticks++ == 10) { $reactor->shutdown(); } }); $reactor->run(); Net-DBus-1.0.0/examples/example-service.pl0000644000076500007650000000273111603165524020511 0ustar berrangeberrange#!/usr/bin/perl use warnings; use strict; use Carp qw(confess cluck); use Net::DBus; use Net::DBus::Service; use Net::DBus::Reactor; #... continued at botom package SomeObject; use base qw(Net::DBus::Object); use Net::DBus::Exporter qw(org.designfu.SampleInterface); #use Class::MethodMaker [ scalar => [ qw(name email age) ]]; #dbus_property("name", "string"); #dbus_property("email", "string", "read"); #dbus_property("age", "int32", "write"); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/SomeObject"); bless $self, $class; return $self; } dbus_method("HelloWorld", ["string"], [["array", "string"]], { param_names => ["message"], return_names => ["reply"] }); sub HelloWorld { my $self = shift; my $message = shift; print "Do hello world\n"; print $message, "\n"; return ["Hello", " from example-service.pl"]; } dbus_method("GetDict", [], [["dict", "string", "string"]]); sub GetDict { my $self = shift; print "Do get dict\n"; return {"first" => "Hello Dict", "second" => " from example-service.pl"}; } dbus_method("GetTuple", [], [["struct", "string", "string"]]); sub GetTuple { my $self = shift; print "Do get tuple\n"; return ["Hello Tuple", " from example-service.pl"]; } package main; my $bus = Net::DBus->session(); my $service = $bus->export_service("org.designfu.SampleService"); my $object = SomeObject->new($service); Net::DBus::Reactor->main->run(); Net-DBus-1.0.0/examples/lshal.pl0000644000076500007650000000120311603165524016514 0ustar berrangeberrange#!/usr/bin/perl -w use strict; use Net::DBus; my $bus = Net::DBus->system; # Get a handle to the HAL service my $hal = $bus->get_service("org.freedesktop.Hal"); # Get the device manager my $manager = $hal->get_object("/org/freedesktop/Hal/Manager", "org.freedesktop.Hal.Manager"); print "Warning. There may be a slight pause while this next\n"; print "method times out, if your version of HAL still just\n"; print "silently ignores unsupported method calls, rather than\n"; print "returning an error. The timeout is ~60 seconds\n"; # List devices foreach my $dev (sort { $a cmp $b } @{$manager->GetAllDevices}) { print $dev, "\n"; } Net-DBus-1.0.0/META.yml0000644000076500007650000000142211603165543014513 0ustar berrangeberrange--- #YAML:1.0 name: Net-DBus abstract: Extension for the DBus bindings version: 1.0.0 author: - Daniel P. Berrange license: gpl generated_by: ExtUtils::MakeMaker version 6.30 requires: Time::HiRes: 0 XML::Twig: 0 build_requires: Test::More: 0 Test::Pod: 0 Test::Pod::Coverage: 0 resources: license: http://www.gnu.org/licenses/gpl.html homepage: http://www.freedesktop.org/wiki/Software/dbus repository: http://hg.berrange.com/libraries/net-dbus--devel MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/ distribution_type: module meta-spec: version: 1.3 url: http://module-build.sourceforge.net/META-spec-v1.3.html Net-DBus-1.0.0/Net-DBus.spec0000644000076500007650000000306511603165543015504 0ustar berrangeberrange# Automatically generated by DBus.spec.PL %define appname Net-DBus %define _extra_release %{?extra_release:%{extra_release}} Summary: Perl API to the DBus message system Name: perl-%{appname} Version: 1.0.0 Release: 1%{_extra_release} License: GPLv2+ or Artistic Group: Development/Libraries URL: http://search.cpan.org/dist/%{appname} Source0: http://www.cpan.org/modules/by-module/Net/%{appname}-%{version}.tar.gz BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version)) Requires: dbus >= 1.0.0 BuildRequires: dbus-devel > 1.0.0 BuildRequires: perl(XML::Twig) BuildRequires: perl(Time::HiRes) BuildRequires: perl(Test::More) BuildRequires: perl(Test::Pod) BuildRequires: perl(Test::Pod::Coverage) %description Provides a Perl API to the DBus message system %prep %setup -q -n %{appname}-%{version} %build if [ -z "$DBUS_HOME" ]; then %{__perl} Makefile.PL INSTALLDIRS=vendor else %{__perl} Makefile.PL INSTALLDIRS=vendor DBUS_HOME=$DBUS_HOME fi make %{?_smp_mflags} %install rm -rf $RPM_BUILD_ROOT make pure_install PERL_INSTALL_ROOT=$RPM_BUILD_ROOT find $RPM_BUILD_ROOT -name perllocal.pod -exec rm -f {} \; find $RPM_BUILD_ROOT -name .packlist -exec rm -f {} \; %{_fixperms} $RPM_BUILD_ROOT/* %check make test %clean rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root) %doc README CHANGES AUTHORS LICENSE examples/*.pl %{_mandir}/man3/* %{perl_vendorarch}/Net/DBus.pm %{perl_vendorarch}/Net/DBus/ %{perl_vendorarch}/auto/Net/DBus %changelog Net-DBus-1.0.0/autobuild.sh0000755000076500007650000000225111603165524015571 0ustar berrangeberrange#!/bin/sh # # This script is used to Test::AutoBuild (http://www.autobuild.org) # to perform automated builds of the DBus module NAME=Net-DBus set -e make -k realclean ||: rm -rf MANIFEST blib pm_to_blib perl Makefile.PL PREFIX=$AUTOBUILD_INSTALL_ROOT # Build the RPM. make make manifest if [ -z "$USE_COVER" ]; then perl -MDevel::Cover -e '' 1>/dev/null 2>&1 && USE_COVER=1 || USE_COVER=0 fi if [ -z "$SKIP_TESTS" -o "$SKIP_TESTS" = "0" ]; then if [ "$USE_COVER" = "1" ]; then cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover make test cover mkdir blib/coverage cp -a cover_db/*.html cover_db/*.css blib/coverage mv blib/coverage/coverage.html blib/coverage/index.html else make test fi fi make install rm -f $NAME-*.tar.gz make dist if [ -f /usr/bin/rpmbuild ]; then if [ -n "$AUTOBUILD_COUNTER" ]; then EXTRA_RELEASE=".auto$AUTOBUILD_COUNTER" else NOW=`date +"%s"` EXTRA_RELEASE=".$USER$NOW" fi # The --nodeps bit is a nasty hack to force build # against the dbus from autobuild, rather than a # (non-existant) installed RPM rpmbuild -ta --define "extra_release $EXTRA_RELEASE" --clean $NAME-*.tar.gz --nodeps fi Net-DBus-1.0.0/META.yml.PL0000644000076500007650000000226011603165524015025 0ustar berrangeberrange# Copyright (C) 2008 Daniel Berrange use strict; use warnings; die unless (scalar @ARGV == 1); open SRC, "lib/Net/DBus.pm" or die "lib/Net/DBus.pm: $!"; our $VERSION; while () { if (/\$VERSION\s*=\s*'(.*)'/) { $VERSION=$1; } } close SRC; local $/ = undef; $_ = ; s/\@VERSION\@/$VERSION/g; open SPEC, ">$ARGV[0]" or die "$!"; print SPEC $_; close SPEC; __DATA__ --- #YAML:1.0 name: Net-DBus abstract: Extension for the DBus bindings version: @VERSION@ author: - Daniel P. Berrange license: gpl generated_by: ExtUtils::MakeMaker version 6.30 requires: Time::HiRes: 0 XML::Twig: 0 build_requires: Test::More: 0 Test::Pod: 0 Test::Pod::Coverage: 0 resources: license: http://www.gnu.org/licenses/gpl.html homepage: http://www.freedesktop.org/wiki/Software/dbus repository: http://hg.berrange.com/libraries/net-dbus--devel MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/ distribution_type: module meta-spec: version: 1.3 url: http://module-build.sourceforge.net/META-spec-v1.3.html Net-DBus-1.0.0/LICENSE0000644000076500007650000005437211603165524014262 0ustar berrangeberrangeNet-DBus may be redistributed and/or modified under the terms of Perl itself. Either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version or b) the "Artistic License" --------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS --------------------------------------------------------------------------- The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Pack- age. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipi- ents of the item may redistribute it under the same conditions they received it. Conditions 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and asso- ciated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Stan- dard Version. 3. You may otherwise modify your copy of this Package in any way, pro- vided that you insert a prominent notice in each changed file stat- ing how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or orga- nization. c) rename any non-standard executables so the names do not con- flict with standard executables, which must also be provided, and provide a separate manual page for each non-standard exe- cutable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the follow- ing: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equiv- alent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Ver- sion. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly com- mercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Pack- age's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever gener- ated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of pro- ducing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other lan- guages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or pro- mote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Net-DBus-1.0.0/MANIFEST.SKIP0000644000076500007650000000020711603165524015137 0ustar berrangeberrangepm_to_blib DBus\.o DBus\.c DBus\.bs .*.old DBus- blib .*\.bak CVS .cvsignore .*~ .#.* #.* .hg ^Makefile$ ^cover_db/ Net-DBus-.*.tar.gz Net-DBus-1.0.0/Net-DBus.spec.PL0000644000076500007650000000403311603165524016011 0ustar berrangeberrange# -*- rpm-spec -*- # Copyright (C) 2004-2006 Daniel Berrange # # $Id: Net-DBus.spec.PL,v 1.8 2006/01/06 16:21:04 dan Exp $ use strict; die unless (scalar @ARGV == 1); open SRC, "lib/Net/DBus.pm" or die "lib/Net/DBus.pm: $!"; our $VERSION; while () { if (/\$VERSION\s*=\s*'(.*)'/) { $VERSION=$1; } } close SRC; local $/ = undef; $_ = ; s/\@VERSION\@/$VERSION/g; open SPEC, ">$ARGV[0]" or die "$!"; print SPEC $_; close SPEC; __DATA__ # Automatically generated by DBus.spec.PL %define appname Net-DBus %define _extra_release %{?extra_release:%{extra_release}} Summary: Perl API to the DBus message system Name: perl-%{appname} Version: @VERSION@ Release: 1%{_extra_release} License: GPLv2+ or Artistic Group: Development/Libraries URL: http://search.cpan.org/dist/%{appname} Source0: http://www.cpan.org/modules/by-module/Net/%{appname}-%{version}.tar.gz BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version)) Requires: dbus >= 1.0.0 BuildRequires: dbus-devel > 1.0.0 BuildRequires: perl(XML::Twig) BuildRequires: perl(Time::HiRes) BuildRequires: perl(Test::More) BuildRequires: perl(Test::Pod) BuildRequires: perl(Test::Pod::Coverage) %description Provides a Perl API to the DBus message system %prep %setup -q -n %{appname}-%{version} %build if [ -z "$DBUS_HOME" ]; then %{__perl} Makefile.PL INSTALLDIRS=vendor else %{__perl} Makefile.PL INSTALLDIRS=vendor DBUS_HOME=$DBUS_HOME fi make %{?_smp_mflags} %install rm -rf $RPM_BUILD_ROOT make pure_install PERL_INSTALL_ROOT=$RPM_BUILD_ROOT find $RPM_BUILD_ROOT -name perllocal.pod -exec rm -f {} \; find $RPM_BUILD_ROOT -name .packlist -exec rm -f {} \; %{_fixperms} $RPM_BUILD_ROOT/* %check make test %clean rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root) %doc README CHANGES AUTHORS LICENSE examples/*.pl %{_mandir}/man3/* %{perl_vendorarch}/Net/DBus.pm %{perl_vendorarch}/Net/DBus/ %{perl_vendorarch}/auto/Net/DBus %changelog Net-DBus-1.0.0/DBus.xs0000644000076500007650000010452111603165524014456 0ustar berrangeberrange/* -*- c -*- * * Copyright (C) 2004-2011 Daniel P. Berrange * * This program is free software; You can redistribute it and/or modify * it under the same terms as Perl itself. Either: * * a) the GNU General Public License as published by the Free * Software Foundation; either version 2, or (at your option) any * later version, * * or * * b) the "Artistic License" * * The file "COPYING" distributed along with this file provides full * details of the terms and conditions of the two licenses. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #if NET_DBUS_DEBUG static int net_dbus_debug = 0; #define DEBUG_MSG(...) if (net_dbus_debug) fprintf(stderr, __VA_ARGS__) #else #define DEBUG_MSG(...) #endif #ifdef __GNUC__ # define ignore_value(x) (({ __typeof__ (x) __x = (x); (void) __x; })) #else # define ignore_value(x) x #endif /* * On 32-bit OS (and some 64-bit) Perl does not have an * integer type capable of storing 64 bit numbers. So * we serialize to/from strings on these platforms */ dbus_int64_t _dbus_parse_int64(SV *sv) { #ifdef USE_64_BIT_ALL return SvIV(sv); #else //DEBUG_MSG("Parrse %s\n", SvPV_nolen(sv)); return strtoll(SvPV_nolen(sv), NULL, 10); #endif } dbus_uint64_t _dbus_parse_uint64(SV *sv) { #ifdef USE_64_BIT_ALL return SvUV(sv); #else //DEBUG_MSG("Parrse %s\n", SvPV_nolen(sv)); return strtoull(SvPV_nolen(sv), NULL, 10); #endif } #ifndef PRId64 #define PRId64 "lld" #endif SV * _dbus_format_int64(dbus_int64_t val) { #ifdef USE_64_BIT_ALL return newSViv(val); #else char buf[100]; int len; len = snprintf(buf, 100, "%" PRId64, val); //DEBUG_MSG("Format i64 [%" PRId64 "] to [%s]\n", val, buf); return newSVpv(buf, len); #endif } #ifndef PRIu64 #define PRIu64 "llu" #endif SV * _dbus_format_uint64(dbus_uint64_t val) { #ifdef USE_64_BIT_ALL return newSVuv(val); #else char buf[100]; int len; len = snprintf(buf, 100, "%" PRIu64, val); //DEBUG_MSG("Format u64 [%" PRIu64 "] to [%s]\n", val, buf); return newSVpv(buf, len); #endif } /* The -1 is required by the contract for dbus_{server,connection}_allocate_slot initialization */ dbus_int32_t connection_data_slot = -1; dbus_int32_t server_data_slot = -1; dbus_int32_t pending_call_data_slot = -1; void _object_release(void *obj) { DEBUG_MSG("Releasing object count on %p\n", obj); SvREFCNT_dec((SV*)obj); } dbus_bool_t _watch_generic(DBusWatch *watch, void *data, char *key, dbus_bool_t server) { SV *selfref; HV *self; SV **call; SV *h_sv; dSP; DEBUG_MSG("Watch generic callback %p %p %s %d\n", watch, data, key, server); if (server) { selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot); } else { selfref = (SV*)dbus_connection_get_data((DBusConnection*)data, connection_data_slot); } self = (HV*)SvRV(selfref); DEBUG_MSG("Got owner %p\n", self); call = hv_fetch(self, key, strlen(key), 0); if (!call) { warn("Could not find watch callback %s for fd %d\n", key, dbus_watch_get_unix_fd(watch)); return FALSE; } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(selfref); h_sv = sv_newmortal(); sv_setref_pv(h_sv, "Net::DBus::Binding::C::Watch", (void*)watch); XPUSHs(h_sv); PUTBACK; call_sv(*call, G_DISCARD); FREETMPS; LEAVE; return 1; } dbus_bool_t _watch_server_add(DBusWatch *watch, void *data) { return _watch_generic(watch, data, "add_watch", 1); } void _watch_server_remove(DBusWatch *watch, void *data) { _watch_generic(watch, data, "remove_watch", 1); } void _watch_server_toggled(DBusWatch *watch, void *data) { _watch_generic(watch, data, "toggled_watch", 1); } dbus_bool_t _watch_connection_add(DBusWatch *watch, void *data) { return _watch_generic(watch, data, "add_watch", 0); } void _watch_connection_remove(DBusWatch *watch, void *data) { _watch_generic(watch, data, "remove_watch", 0); } void _watch_connection_toggled(DBusWatch *watch, void *data) { _watch_generic(watch, data, "toggled_watch", 0); } dbus_bool_t _timeout_generic(DBusTimeout *timeout, void *data, char *key, dbus_bool_t server) { SV *selfref; HV *self; SV **call; SV *h_sv; dSP; if (server) { selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot); } else { selfref = (SV*)dbus_connection_get_data((DBusConnection*)data, connection_data_slot); } self = (HV*)SvRV(selfref); call = hv_fetch(self, key, strlen(key), 0); if (!call) { warn("Could not find timeout callback for %s\n", key); return FALSE; } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs((SV*)selfref); h_sv = sv_newmortal(); sv_setref_pv(h_sv, "Net::DBus::Binding::C::Timeout", (void*)timeout); XPUSHs(h_sv); PUTBACK; call_sv(*call, G_DISCARD); FREETMPS; LEAVE; return 1; } dbus_bool_t _timeout_server_add(DBusTimeout *timeout, void *data) { return _timeout_generic(timeout, data, "add_timeout", 1); } void _timeout_server_remove(DBusTimeout *timeout, void *data) { _timeout_generic(timeout, data, "remove_timeout", 1); } void _timeout_server_toggled(DBusTimeout *timeout, void *data) { _timeout_generic(timeout, data, "toggled_timeout", 1); } dbus_bool_t _timeout_connection_add(DBusTimeout *timeout, void *data) { return _timeout_generic(timeout, data, "add_timeout", 0); } void _timeout_connection_remove(DBusTimeout *timeout, void *data) { _timeout_generic(timeout, data, "remove_timeout", 0); } void _timeout_connection_toggled(DBusTimeout *timeout, void *data) { _timeout_generic(timeout, data, "toggled_timeout", 0); } void _connection_callback (DBusServer *server, DBusConnection *new_connection, void *data) { SV *selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot); HV *self = (HV*)SvRV(selfref); SV **call; SV *value; dSP; call = hv_fetch(self, "_callback", strlen("_callback"), 0); if (!call) { warn("Could not find new connection callback\n"); return; } DEBUG_MSG("Created connection in callback %p\n", new_connection); /* The DESTROY method will de-ref it later */ dbus_connection_ref(new_connection); value = sv_newmortal(); sv_setref_pv(value, "Net::DBus::Binding::C::Connection", (void*)new_connection); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(selfref); XPUSHs(value); PUTBACK; call_sv(*call, G_DISCARD); FREETMPS; LEAVE; } DBusHandlerResult _message_filter(DBusConnection *con, DBusMessage *msg, void *data) { SV *selfref; SV *value; int count; int handled = 0; dSP; selfref = (SV*)dbus_connection_get_data(con, connection_data_slot); DEBUG_MSG("Create message in filter %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); /* Will be de-refed in the DESTROY method */ dbus_message_ref(msg); value = sv_newmortal(); sv_setref_pv(value, "Net::DBus::Binding::C::Message", (void*)msg); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs((SV*)selfref); XPUSHs(value); XPUSHs(data); PUTBACK; count = call_method("_message_filter", G_SCALAR); SPAGAIN; if (count == 1) { handled = POPi; } else { handled = 0; } PUTBACK; DEBUG_MSG("Handled %d %d\n", count, handled); FREETMPS; LEAVE; return handled ? DBUS_HANDLER_RESULT_HANDLED : DBUS_HANDLER_RESULT_NOT_YET_HANDLED; } void _pending_call_callback(DBusPendingCall *call, void *data) { SV *selfref; dSP; DEBUG_MSG("In pending call callback %p\n", call); selfref = (SV*)dbus_pending_call_get_data(call, pending_call_data_slot); dbus_pending_call_ref(call); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs((SV*)selfref); PUTBACK; call_sv(data, G_DISCARD); FREETMPS; LEAVE; } void _filter_release(void *data) { SvREFCNT_dec(data); } void _pending_call_notify_release(void *data) { SvREFCNT_dec(data); } void _path_unregister_callback(DBusConnection *con, void *data) { SvREFCNT_dec(data); } DBusHandlerResult _path_message_callback(DBusConnection *con, DBusMessage *msg, void *data) { SV *self = (SV*)dbus_connection_get_data(con, connection_data_slot); SV *value; dSP; DEBUG_MSG("Got message in callback %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); /* Will be de-refed in the DESTROY method */ dbus_message_ref(msg); value = sv_newmortal(); sv_setref_pv(value, "Net::DBus::Binding::C::Message", (void*)msg); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(self); XPUSHs(value); PUTBACK; call_sv((SV*)data, G_DISCARD); FREETMPS; LEAVE; return DBUS_HANDLER_RESULT_HANDLED; } DBusObjectPathVTable _path_callback_vtable = { _path_unregister_callback, _path_message_callback, NULL, NULL, NULL, NULL }; SV * _sv_from_error (DBusError *error) { HV *hv; if (!error) { warn ("error is NULL"); return &PL_sv_undef; } if (!dbus_error_is_set (error)) { warn ("error is unset"); return &PL_sv_undef; } hv = newHV (); /* map DBusError attributes to hash keys */ ignore_value(hv_store (hv, "name", 4, newSVpv (error->name, 0), 0)); ignore_value(hv_store (hv, "message", 7, newSVpv (error->message, 0), 0)); return sv_bless (newRV_noinc ((SV*) hv), gv_stashpv ("Net::DBus::Error", TRUE)); } void _croak_error (DBusError *error) { sv_setsv (ERRSV, _sv_from_error (error)); /* croak does not return, so we free this now to avoid leaking */ dbus_error_free (error); croak (Nullch); } void _populate_constant(HV *href, char *name, int val) { ignore_value(hv_store(href, name, strlen(name), newSViv(val), 0)); } #define REGISTER_CONSTANT(name, key) _populate_constant(constants, #key, name) MODULE = Net::DBus PACKAGE = Net::DBus PROTOTYPES: ENABLE BOOT: { HV *constants; if (getenv("NET_DBUS_DEBUG")) net_dbus_debug = 1; /* not the 'standard' way of doing perl constants, but a lot easier to maintain */ constants = perl_get_hv("Net::DBus::Binding::Bus::_constants", TRUE); REGISTER_CONSTANT(DBUS_BUS_SYSTEM, SYSTEM); REGISTER_CONSTANT(DBUS_BUS_SESSION, SESSION); REGISTER_CONSTANT(DBUS_BUS_STARTER, STARTER); constants = perl_get_hv("Net::DBus::Binding::Message::_constants", TRUE); REGISTER_CONSTANT(DBUS_TYPE_ARRAY, TYPE_ARRAY); REGISTER_CONSTANT(DBUS_TYPE_BOOLEAN, TYPE_BOOLEAN); REGISTER_CONSTANT(DBUS_TYPE_BYTE, TYPE_BYTE); REGISTER_CONSTANT(DBUS_TYPE_DOUBLE, TYPE_DOUBLE); REGISTER_CONSTANT(DBUS_TYPE_INT16, TYPE_INT16); REGISTER_CONSTANT(DBUS_TYPE_INT32, TYPE_INT32); REGISTER_CONSTANT(DBUS_TYPE_INT64, TYPE_INT64); REGISTER_CONSTANT(DBUS_TYPE_INVALID, TYPE_INVALID); REGISTER_CONSTANT(DBUS_TYPE_STRUCT, TYPE_STRUCT); REGISTER_CONSTANT(DBUS_TYPE_SIGNATURE, TYPE_SIGNATURE); REGISTER_CONSTANT(DBUS_TYPE_OBJECT_PATH, TYPE_OBJECT_PATH); REGISTER_CONSTANT(DBUS_TYPE_DICT_ENTRY, TYPE_DICT_ENTRY); REGISTER_CONSTANT(DBUS_TYPE_STRING, TYPE_STRING); REGISTER_CONSTANT(DBUS_TYPE_UINT16, TYPE_UINT16); REGISTER_CONSTANT(DBUS_TYPE_UINT32, TYPE_UINT32); REGISTER_CONSTANT(DBUS_TYPE_UINT64, TYPE_UINT64); REGISTER_CONSTANT(DBUS_TYPE_VARIANT, TYPE_VARIANT); REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_CALL, MESSAGE_TYPE_METHOD_CALL); REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_RETURN, MESSAGE_TYPE_METHOD_RETURN); REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_ERROR, MESSAGE_TYPE_ERROR); REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_SIGNAL, MESSAGE_TYPE_SIGNAL); REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_INVALID, MESSAGE_TYPE_INVALID); constants = perl_get_hv("Net::DBus::Binding::Watch::_constants", TRUE); REGISTER_CONSTANT(DBUS_WATCH_READABLE, READABLE); REGISTER_CONSTANT(DBUS_WATCH_WRITABLE, WRITABLE); REGISTER_CONSTANT(DBUS_WATCH_ERROR, ERROR); REGISTER_CONSTANT(DBUS_WATCH_HANGUP, HANGUP); dbus_connection_allocate_data_slot(&connection_data_slot); dbus_server_allocate_data_slot(&server_data_slot); dbus_pending_call_allocate_data_slot(&pending_call_data_slot); } MODULE = Net::DBus::Binding::Connection PACKAGE = Net::DBus::Binding::Connection PROTOTYPES: ENABLE DBusConnection * _open(address) char *address; PREINIT: DBusError error; DBusConnection *con; CODE: dbus_error_init(&error); DEBUG_MSG("Open connection shared %s\n", address); con = dbus_connection_open(address, &error); if (!con) { _croak_error (&error); } dbus_connection_ref(con); RETVAL = con; OUTPUT: RETVAL DBusConnection * _open_private(address) char *address; PREINIT: DBusError error; DBusConnection *con; CODE: dbus_error_init(&error); DEBUG_MSG("Open connection private %s\n", address); con = dbus_connection_open_private(address, &error); if (!con) { _croak_error (&error); } dbus_connection_ref(con); RETVAL = con; OUTPUT: RETVAL MODULE = Net::DBus::Binding::C::Connection PACKAGE = Net::DBus::Binding::C::Connection void _set_owner(con, owner) DBusConnection *con; SV *owner; CODE: SvREFCNT_inc(owner); dbus_connection_set_data(con, connection_data_slot, owner, _object_release); void dbus_connection_disconnect(con) DBusConnection *con; CODE: DEBUG_MSG("Closing connection %p\n", con); dbus_connection_close(con); void dbus_connection_ref(con) DBusConnection *con; void dbus_connection_unref(con) DBusConnection *con; int dbus_connection_get_is_connected(con) DBusConnection *con; int dbus_connection_get_is_authenticated(con) DBusConnection *con; void dbus_connection_flush(con) DBusConnection *con; int _send(con, msg) DBusConnection *con; DBusMessage *msg; PREINIT: dbus_uint32_t serial; CODE: if (!dbus_connection_send(con, msg, &serial)) { croak("not enough memory to send message"); } RETVAL = serial; OUTPUT: RETVAL DBusMessage * _send_with_reply_and_block(con, msg, timeout) DBusConnection *con; DBusMessage *msg; int timeout; PREINIT: DBusMessage *reply; DBusError error; CODE: dbus_error_init(&error); if (!(reply = dbus_connection_send_with_reply_and_block(con, msg, timeout, &error))) { _croak_error(&error); } DEBUG_MSG("Create msg reply %p\n", reply); DEBUG_MSG(" Type %d\n", dbus_message_get_type(reply)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(reply) ? dbus_message_get_interface(reply) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(reply) ? dbus_message_get_path(reply) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(reply) ? dbus_message_get_member(reply) : ""); RETVAL = reply; OUTPUT: RETVAL DBusPendingCall * _send_with_reply(con, msg, timeout) DBusConnection *con; DBusMessage *msg; int timeout; PREINIT: DBusPendingCall *reply; CODE: if (!dbus_connection_send_with_reply(con, msg, &reply, timeout)) { croak("not enough memory to send message"); } DEBUG_MSG("Create pending call %p\n", reply); RETVAL = reply; OUTPUT: RETVAL DBusMessage * dbus_connection_borrow_message(con) DBusConnection *con; void dbus_connection_return_message(con, msg) DBusConnection *con; DBusMessage *msg; void dbus_connection_steal_borrowed_message(con, msg) DBusConnection *con; DBusMessage *msg; DBusMessage * dbus_connection_pop_message(con) DBusConnection *con; void _dispatch(con) DBusConnection *con; CODE: DEBUG_MSG("IN dispatch\n"); while(dbus_connection_dispatch(con) == DBUS_DISPATCH_DATA_REMAINS); DEBUG_MSG("Completed \n"); void _set_watch_callbacks(con) DBusConnection *con; CODE: if (!dbus_connection_set_watch_functions(con, _watch_connection_add, _watch_connection_remove, _watch_connection_toggled, con, NULL)) { croak("not enough memory to set watch functions on connection"); } void _set_timeout_callbacks(con) DBusConnection *con; CODE: if (!dbus_connection_set_timeout_functions(con, _timeout_connection_add, _timeout_connection_remove, _timeout_connection_toggled, con, NULL)) { croak("not enough memory to set timeout functions on connection"); } void _register_object_path(con, path, code) DBusConnection *con; char *path; SV *code; CODE: SvREFCNT_inc(code); if (!(dbus_connection_register_object_path(con, path, &_path_callback_vtable, code))) { croak("failure when registering object path"); } void _unregister_object_path(con, path) DBusConnection *con; char *path; CODE: /* The associated data will be free'd by the previously registered callback */ if (!(dbus_connection_unregister_object_path(con, path))) { croak("failure when unregistering object path"); } void _register_fallback(con, path, code) DBusConnection *con; char *path; SV *code; CODE: SvREFCNT_inc(code); if (!(dbus_connection_register_fallback(con, path, &_path_callback_vtable, code))) { croak("failure when registering fallback object path"); } void _add_filter(con, code) DBusConnection *con; SV *code; CODE: SvREFCNT_inc(code); DEBUG_MSG("Adding filter %p\n", code); dbus_connection_add_filter(con, _message_filter, code, _filter_release); dbus_bool_t dbus_bus_register(con) DBusConnection *con; PREINIT: DBusError error; int reply; CODE: dbus_error_init(&error); if (!(reply = dbus_bus_register(con, &error))) { _croak_error(&error); } RETVAL = reply; OUTPUT: RETVAL void dbus_bus_add_match(con, rule) DBusConnection *con; char *rule; PREINIT: DBusError error; CODE: dbus_error_init(&error); DEBUG_MSG("Adding match %s\n", rule); dbus_bus_add_match(con, rule, &error); if (dbus_error_is_set(&error)) { _croak_error(&error); } void dbus_bus_remove_match(con, rule) DBusConnection *con; char *rule; PREINIT: DBusError error; CODE: dbus_error_init(&error); DEBUG_MSG("Removeing match %s\n", rule); dbus_bus_remove_match(con, rule, &error); if (dbus_error_is_set(&error)) { _croak_error(&error); } const char * dbus_bus_get_unique_name(con) DBusConnection *con; int dbus_bus_request_name(con, service_name) DBusConnection *con; char *service_name; PREINIT: DBusError error; int reply; CODE: dbus_error_init(&error); if (!(reply = dbus_bus_request_name(con, service_name, 0, &error))) { _croak_error(&error); } RETVAL = reply; OUTPUT: RETVAL void DESTROY(con) DBusConnection *con; CODE: DEBUG_MSG("Unrefing connection %p\n", con); dbus_connection_unref(con); MODULE = Net::DBus::Binding::Server PACKAGE = Net::DBus::Binding::Server PROTOTYPES: ENABLE DBusServer * _open(address) char *address; PREINIT: DBusError error; DBusServer *server; CODE: dbus_error_init(&error); server = dbus_server_listen(address, &error); DEBUG_MSG("Created server %p on address %s\n", server, address); if (!server) { _croak_error(&error); } if (!dbus_server_set_auth_mechanisms(server, NULL)) { croak("not enough memory to server auth mechanisms"); } RETVAL = server; OUTPUT: RETVAL MODULE = Net::DBus::Binding::C::Server PACKAGE = Net::DBus::Binding::C::Server void _set_owner(server, owner) DBusServer *server; SV *owner; CODE: SvREFCNT_inc(owner); dbus_server_set_data(server, server_data_slot, owner, _object_release); void dbus_server_disconnect(server) DBusServer *server; int dbus_server_get_is_connected(server) DBusServer *server; void _set_watch_callbacks(server) DBusServer *server; CODE: if (!dbus_server_set_watch_functions(server, _watch_server_add, _watch_server_remove, _watch_server_toggled, server, NULL)) { croak("not enough memory to set watch functions on server"); } void _set_timeout_callbacks(server) DBusServer *server; CODE: if (!dbus_server_set_timeout_functions(server, _timeout_server_add, _timeout_server_remove, _timeout_server_toggled, server, NULL)) { croak("not enough memory to set timeout functions on server"); } void _set_connection_callback(server) DBusServer *server; CODE: dbus_server_set_new_connection_function(server, _connection_callback, server, NULL); void DESTROY(server) DBusServer *server; CODE: DEBUG_MSG("Destroying server %p\n", server); dbus_server_unref(server); MODULE = Net::DBus::Binding::Bus PACKAGE = Net::DBus::Binding::Bus PROTOTYPES: ENABLE DBusConnection * _open(type) DBusBusType type; PREINIT: DBusError error; DBusConnection *con; CODE: dbus_error_init(&error); DEBUG_MSG("Open bus shared %d\n", type); con = dbus_bus_get(type, &error); if (!con) { _croak_error(&error); } dbus_connection_ref(con); RETVAL = con; OUTPUT: RETVAL DBusConnection * _open_private(type) DBusBusType type; PREINIT: DBusError error; DBusConnection *con; CODE: dbus_error_init(&error); DEBUG_MSG("Open bus private %d\n", type); con = dbus_bus_get_private(type, &error); if (!con) { _croak_error(&error); } dbus_connection_ref(con); RETVAL = con; OUTPUT: RETVAL MODULE = Net::DBus::Binding::Message PACKAGE = Net::DBus::Binding::Message PROTOTYPES: ENABLE DBusMessage * _create(type) IV type; PREINIT: DBusMessage *msg; CODE: msg = dbus_message_new(type); if (!msg) { croak("No memory to allocate message"); } DEBUG_MSG("Create msg new %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); RETVAL = msg; OUTPUT: RETVAL DBusMessageIter * _iterator_append(msg) DBusMessage *msg; CODE: RETVAL = dbus_new(DBusMessageIter, 1); dbus_message_iter_init_append(msg, RETVAL); OUTPUT: RETVAL DBusMessageIter * _iterator(msg) DBusMessage *msg; CODE: RETVAL = dbus_new(DBusMessageIter, 1); dbus_message_iter_init(msg, RETVAL); OUTPUT: RETVAL MODULE = Net::DBus::Binding::C::Message PACKAGE = Net::DBus::Binding::C::Message void DESTROY(msg) DBusMessage *msg; CODE: DEBUG_MSG("De-referencing message %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); dbus_message_unref(msg); dbus_bool_t dbus_message_get_no_reply(msg) DBusMessage *msg; void dbus_message_set_no_reply(msg,flag) DBusMessage *msg; dbus_bool_t flag; int dbus_message_get_type(msg) DBusMessage *msg; const char * dbus_message_get_interface(msg) DBusMessage *msg; const char * dbus_message_get_path(msg) DBusMessage *msg; const char * dbus_message_get_destination(msg) DBusMessage *msg; const char * dbus_message_get_sender(msg) DBusMessage *msg; dbus_uint32_t dbus_message_get_serial(msg) DBusMessage *msg; const char * dbus_message_get_member(msg) DBusMessage *msg; const char * dbus_message_get_error_name(msg) DBusMessage *msg; const char * dbus_message_get_signature(msg) DBusMessage *msg; void dbus_message_set_sender(msg, sender); DBusMessage *msg; const char *sender; void dbus_message_set_destination(msg, dest); DBusMessage *msg; const char *dest; MODULE = Net::DBus::Binding::Message::Signal PACKAGE = Net::DBus::Binding::Message::Signal PROTOTYPES: ENABLE DBusMessage * _create(path, interface, name) char *path; char *interface; char *name; PREINIT: DBusMessage *msg; CODE: msg = dbus_message_new_signal(path, interface, name); if (!msg) { croak("No memory to allocate message"); } DEBUG_MSG("Create msg new signal %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); RETVAL = msg; OUTPUT: RETVAL MODULE = Net::DBus::Binding::Message::MethodCall PACKAGE = Net::DBus::Binding::Message::MethodCall PROTOTYPES: ENABLE DBusMessage * _create(service, path, interface, method) char *service; char *path; char *interface; char *method; PREINIT: DBusMessage *msg; CODE: msg = dbus_message_new_method_call(service, path, interface, method); if (!msg) { croak("No memory to allocate message"); } DEBUG_MSG("Create msg new method call %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); RETVAL = msg; OUTPUT: RETVAL MODULE = Net::DBus::Binding::Message::MethodReturn PACKAGE = Net::DBus::Binding::Message::MethodReturn PROTOTYPES: ENABLE DBusMessage * _create(call) DBusMessage *call; PREINIT: DBusMessage *msg; CODE: msg = dbus_message_new_method_return(call); if (!msg) { croak("No memory to allocate message"); } dbus_message_set_interface(msg, dbus_message_get_interface(call)); dbus_message_set_path(msg, dbus_message_get_path(call)); dbus_message_set_member(msg, dbus_message_get_member(call)); DEBUG_MSG("Create msg new method return %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); RETVAL = msg; OUTPUT: RETVAL MODULE = Net::DBus::Binding::Message::Error PACKAGE = Net::DBus::Binding::Message::Error PROTOTYPES: ENABLE DBusMessage * _create(replyto, name, message) DBusMessage *replyto; char *name; char *message; PREINIT: DBusMessage *msg; CODE: msg = dbus_message_new_error(replyto, name, message); if (!msg) { croak("No memory to allocate message"); } DEBUG_MSG("Create msg new error %p\n", msg); DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); RETVAL = msg; OUTPUT: RETVAL MODULE = Net::DBus::Binding::C::PendingCall PACKAGE = Net::DBus::Binding::C::PendingCall PROTOTYPES: ENABLE DBusMessage * _steal_reply(call) DBusPendingCall *call; PREINIT: DBusMessage *msg; CODE: DEBUG_MSG("Stealing pending call reply %p\n", call); msg = dbus_pending_call_steal_reply(call); dbus_message_ref(msg); DEBUG_MSG("Got reply message %p\n", msg); RETVAL = msg; OUTPUT: RETVAL void dbus_pending_call_block(call) DBusPendingCall *call; dbus_bool_t dbus_pending_call_get_completed(call) DBusPendingCall *call; void dbus_pending_call_cancel(call) DBusPendingCall *call; void _set_notify(call, code) DBusPendingCall *call; SV *code; CODE: SvREFCNT_inc(code); DEBUG_MSG("Adding pending call notify %p\n", code); dbus_pending_call_set_notify(call, _pending_call_callback, code, _pending_call_notify_release); void DESTROY (call) DBusPendingCall *call; CODE: DEBUG_MSG("Unrefing pending call %p", call); dbus_pending_call_unref(call); MODULE = Net::DBus::Binding::C::Watch PACKAGE = Net::DBus::Binding::C::Watch int get_fileno(watch) DBusWatch *watch; CODE: RETVAL = dbus_watch_get_unix_fd(watch); OUTPUT: RETVAL unsigned int get_flags(watch) DBusWatch *watch; CODE: RETVAL = dbus_watch_get_flags(watch); OUTPUT: RETVAL dbus_bool_t is_enabled(watch) DBusWatch *watch; CODE: RETVAL = dbus_watch_get_enabled(watch); OUTPUT: RETVAL void handle(watch, flags) DBusWatch *watch; unsigned int flags; CODE: DEBUG_MSG("Handling event %d on fd %d (%p)\n", flags, dbus_watch_get_unix_fd(watch), watch); dbus_watch_handle(watch, flags); void * get_data(watch) DBusWatch *watch; CODE: RETVAL = dbus_watch_get_data(watch); OUTPUT: RETVAL void set_data(watch, data) DBusWatch *watch; void *data; CODE: dbus_watch_set_data(watch, data, NULL); MODULE = Net::DBus::Binding::C::Timeout PACKAGE = Net::DBus::Binding::C::Timeout int get_interval(timeout) DBusTimeout *timeout; CODE: RETVAL = dbus_timeout_get_interval(timeout); OUTPUT: RETVAL dbus_bool_t is_enabled(timeout) DBusTimeout *timeout; CODE: RETVAL = dbus_timeout_get_enabled(timeout); OUTPUT: RETVAL void handle(timeout) DBusTimeout *timeout; CODE: DEBUG_MSG("Handling timeout event %p\n", timeout); dbus_timeout_handle(timeout); void * get_data(timeout) DBusTimeout *timeout; CODE: RETVAL = dbus_timeout_get_data(timeout); OUTPUT: RETVAL void set_data(timeout, data) DBusTimeout *timeout; void *data; CODE: dbus_timeout_set_data(timeout, data, NULL); MODULE = Net::DBus::Binding::Iterator PACKAGE = Net::DBus::Binding::Iterator DBusMessageIter * _recurse(iter) DBusMessageIter *iter; CODE: RETVAL = dbus_new(DBusMessageIter, 1); dbus_message_iter_recurse(iter, RETVAL); OUTPUT: RETVAL DBusMessageIter * _open_container(iter, type, sig) DBusMessageIter *iter; int type; char *sig; CODE: RETVAL = dbus_new(DBusMessageIter, 1); if (!dbus_message_iter_open_container(iter, type, sig && *sig == '\0' ? NULL : sig, RETVAL)) { dbus_free(RETVAL); croak("failed to open iterator container"); } OUTPUT: RETVAL void _close_container(iter, sub_iter) DBusMessageIter *iter; DBusMessageIter *sub_iter; CODE: dbus_message_iter_close_container(iter, sub_iter); int get_arg_type(iter) DBusMessageIter *iter; CODE: RETVAL = dbus_message_iter_get_arg_type(iter); OUTPUT: RETVAL int get_element_type(iter) DBusMessageIter *iter; CODE: RETVAL = dbus_message_iter_get_element_type(iter); OUTPUT: RETVAL dbus_bool_t has_next(iter) DBusMessageIter *iter; CODE: RETVAL = dbus_message_iter_has_next(iter); OUTPUT: RETVAL dbus_bool_t next(iter) DBusMessageIter *iter; CODE: RETVAL = dbus_message_iter_next(iter); OUTPUT: RETVAL dbus_bool_t get_boolean(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL unsigned char get_byte(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_int16_t get_int16(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_uint16_t get_uint16(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_int32_t get_int32(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_uint32_t get_uint32(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_int64_t _get_int64(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL dbus_uint64_t _get_uint64(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL double get_double(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL char * get_string(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL char * get_signature(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL char * get_object_path(iter) DBusMessageIter *iter; CODE: dbus_message_iter_get_basic(iter, &RETVAL); OUTPUT: RETVAL void append_boolean(iter, val) DBusMessageIter *iter; dbus_bool_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_BOOLEAN, &val)) { croak("cannot append boolean"); } void append_byte(iter, val) DBusMessageIter *iter; unsigned char val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_BYTE, &val)) { croak("cannot append byte"); } void append_int16(iter, val) DBusMessageIter *iter; dbus_int16_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT16, &val)) { croak("cannot append int16"); } void append_uint16(iter, val) DBusMessageIter *iter; dbus_uint16_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT16, &val)) { croak("cannot append uint16"); } void append_int32(iter, val) DBusMessageIter *iter; dbus_int32_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT32, &val)) { croak("cannot append int32"); } void append_uint32(iter, val) DBusMessageIter *iter; dbus_uint32_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT32, &val)) { croak("cannot append uint32"); } void _append_int64(iter, val) DBusMessageIter *iter; dbus_int64_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT64, &val)) { croak("cannot append int64"); } void _append_uint64(iter, val) DBusMessageIter *iter; dbus_uint64_t val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &val)) { croak("cannot append uint64"); } void append_double(iter, val) DBusMessageIter *iter; double val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_DOUBLE, &val)) { croak("cannot append double"); } void append_string(iter, val) DBusMessageIter *iter; char *val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_STRING, &val)) { croak("cannot append string"); } void append_object_path(iter, val) DBusMessageIter *iter; char *val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_OBJECT_PATH, &val)) { croak("cannot append object path"); } void append_signature(iter, val) DBusMessageIter *iter; char *val; CODE: if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_SIGNATURE, &val)) { croak("cannot append signature"); } void DESTROY(iter) DBusMessageIter *iter; CODE: DEBUG_MSG("Destroying iterator %p\n", iter); dbus_free(iter); MODULE = Net::DBus PACKAGE = Net::DBus Net-DBus-1.0.0/lib/0000755000076500007650000000000011603165554014013 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/0000755000076500007650000000000011603165554014541 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/0000755000076500007650000000000011603165554015376 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/Object.pm0000644000076500007650000004656711603165524017161 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Object - Provide objects to the bus for clients to use =head1 SYNOPSIS # Connecting an object to the bus, under a service package main; use Net::DBus; # Attach to the bus my $bus = Net::DBus->find; # Acquire a service 'org.demo.Hello' my $service = $bus->export_service("org.demo.Hello"); # Export our object within the service my $object = Demo::HelloWorld->new($service); ....rest of program... # Define a new package for the object we're going # to export package Demo::HelloWorld; # Specify the main interface provided by our object use Net::DBus::Exporter qw(org.example.demo.Greeter); # We're going to be a DBus object use base qw(Net::DBus::Object); # Export a 'Greeting' signal taking a stringl string parameter dbus_signal("Greeting", ["string"]); # Export 'Hello' as a method accepting a single string # parameter, and returning a single string value dbus_method("Hello", ["string"], ["string"]); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/org/demo/HelloWorld"); bless $self, $class; return $self; } sub Hello { my $self = shift; my $name = shift; $self->emit_signal("Greeting", "Hello $name"); return "Said hello to $name"; } # Export 'Goodbye' as a method accepting a single string # parameter, and returning a single string, but put it # in the 'org.exaple.demo.Farewell' interface dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell"); sub Goodbye { my $self = shift; my $name = shift; $self->emit_signal("Greeting", "Goodbye $name"); return "Said goodbye to $name"; } =head1 DESCRIPTION This the base of all objects which are exported to the message bus. It provides the core support for type introspection required for objects exported to the message. When sub-classing this object, methods can be created & tested as per normal Perl modules. Then just as the L module is used to export methods within a script, the L module is used to export methods (and signals) to the message bus. All packages inheriting from this, will automatically have the interface C registered with L, and the C method within this exported. =head1 METHODS =over 4 =cut package Net::DBus::Object; use 5.006; use strict; use warnings; our $ENABLE_INTROSPECT; BEGIN { if ($ENV{DBUS_DISABLE_INTROSPECT}) { $ENABLE_INTROSPECT = 0; } else { $ENABLE_INTROSPECT = 1; } } use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable"; dbus_method("Introspect", [], ["string"]); dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties"); dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties"); dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties"); =item my $object = Net::DBus::Object->new($service, $path) This creates a new DBus object with an path of C<$path> registered within the service C<$service>. The C<$path> parameter should be a string complying with the usual DBus requirements for object paths, while the C<$service> parameter should be an instance of L. The latter is typically obtained by calling the C method on the L object. =item my $object = Net::DBus::Object->new($parentobj, $subpath) This creates a new DBus child object with an path of C<$subpath> relative to its parent C<$parentobj>. The C<$subpath> parameter should be a string complying with the usual DBus requirements for object paths, while the C<$parentobj> parameter should be an instance of L. =cut sub new { my $class = shift; my $self = {}; my $parent = shift; my $path = shift; $self->{parent} = $parent; if ($parent->isa(__PACKAGE__)) { $self->{service} = $parent->get_service; $self->{object_path} = $parent->get_object_path . $path; } else { $self->{service} = $parent; $self->{object_path} = $path; } $self->{interface} = shift; $self->{introspector} = undef; $self->{introspected} = 0; $self->{callbacks} = {}; $self->{children} = {}; bless $self, $class; if ($self->{parent}->isa(__PACKAGE__)) { $self->{parent}->_register_child($self); } else { $self->get_service->_register_object($self); } return $self; } =item $object->disconnect(); This method disconnects the object from the bus, such that it will no longer receive messages sent by other clients. Any child objects will be recursively disconnected too. After an object has been disconnected, it is possible for Perl to garbage collect the object instance. It will also make it possible to connect a newly created object to the same path. =cut sub disconnect { my $self = shift; return unless $self->{parent}; foreach my $child (keys %{$self->{children}}) { $self->_unregister_child($self->{children}->{$child}); } if ($self->{parent}->isa(__PACKAGE__)) { $self->{parent}->_unregister_child($self); } else { $self->get_service->_unregister_object($self); } $self->{parent} = undef; } =item my $bool = $object->is_connected Returns a true value if the object is connected to the bus, and thus capable of being accessed by remote clients. Returns false if the object is disconnected & thus ready for garbage collection. All objects start off in the connected state, and will only transition if the C method is called. =cut sub is_connected { my $self = shift; return 0 unless $self->{parent}; if ($self->{parent}->isa(__PACKAGE__)) { return $self->{parent}->is_connected; } return 1; } sub DESTROY { my $self = shift; # XXX there are some issues during global # destruction which need to be better figured # out before this will work #$self->disconnect; } sub _register_child { my $self = shift; my $object = shift; $self->get_service->_register_object($object); $self->{children}->{$object->get_object_path} = $object; } sub _unregister_child { my $self = shift; my $object = shift; $self->get_service->_unregister_object($object); delete $self->{children}->{$object->get_object_path}; } # return a list of sub nodes for this object sub _get_sub_nodes { my $self = shift; my %uniq; my $base = "$self->{object_path}/"; foreach ( keys( %{$self->{children}} ) ) { m/^$base([^\/]+)/; $uniq{$1} = 1; } return sort( keys( %uniq ) ); } =item my $service = $object->get_service Retrieves the L object within which this object is exported. =cut sub get_service { my $self = shift; return $self->{service}; } =item my $path = $object->get_object_path Retrieves the path under which this object is exported =cut sub get_object_path { my $self = shift; return $self->{object_path}; } =item $object->emit_signal_in($name, $interface, $client, @args); Emits a signal from the object, with a name of C<$name>. If the C<$interface> parameter is defined, the signal will be scoped within that interface. If the C<$client> parameter is defined, the signal will be unicast to that client on the bus. The signal and the data types of the arguments C<@args> must have been registered with L by calling the C method. =cut sub emit_signal_in { my $self = shift; my $name = shift; my $interface = shift; my $destination = shift; my @args = @_; die "object is disconnected from the bus" unless $self->is_connected; my $con = $self->get_service->get_bus->get_connection; my $signal = $con->make_signal_message($self->get_object_path, $interface, $name); if ($destination) { $signal->set_destination($destination); } my $ins = $self->_introspector; if ($ins) { $ins->encode($signal, "signals", $name, "params", @args); } else { $signal->append_args_list(@args); } $con->send($signal); # Short circuit locally registered callbacks if (exists $self->{callbacks}->{$interface} && exists $self->{callbacks}->{$interface}->{$name}) { my $cb = $self->{callbacks}->{$interface}->{$name}; &$cb(@args); } } =item $self->emit_signal_to($name, $client, @args); Emits a signal from the object, with a name of C<$name>. The signal and the data types of the arguments C<@args> must have been registered with L by calling the C method. The signal will be sent only to the client named by the C<$client> parameter. =cut sub emit_signal_to { my $self = shift; my $name = shift; my $destination = shift; my @args = @_; my $intro = $self->_introspector; if (!$intro) { die "no introspection data available for '" . $self->get_object_path . "', use the emit_signal_in method instead"; } my @interfaces = $intro->has_signal($name); if ($#interfaces == -1) { die "no signal with name '$name' is exported in object '" . $self->get_object_path . "'\n"; } elsif ($#interfaces > 0) { die "signal '$name' is exported in more than one interface of '" . $self->get_object_path . "', use the emit_signal_in method instead."; } $self->emit_signal_in($name, $interfaces[0], $destination, @args); } =item $self->emit_signal($name, @args); Emits a signal from the object, with a name of C<$name>. The signal and the data types of the arguments C<@args> must have been registered with L by calling the C method. The signal will be broadcast to all clients on the bus. =cut sub emit_signal { my $self = shift; my $name = shift; my @args = @_; $self->emit_signal_to($name, undef, @args); } =item $object->connect_to_signal_in($name, $interface, $coderef); Connects a callback to a signal emitted by the object. The C<$name> parameter is the name of the signal within the object, and C<$coderef> is a reference to an anonymous subroutine. When the signal C<$name> is emitted by the remote object, the subroutine C<$coderef> will be invoked, and passed the parameters from the signal. The C<$interface> parameter is used to specify the explicit interface defining the signal to connect to. =cut sub connect_to_signal_in { my $self = shift; my $name = shift; my $interface = shift; my $code = shift; die "object is disconnected from the bus" unless $self->is_connected; $self->{callbacks}->{$interface} = {} unless exists $self->{callbacks}->{$interface}; $self->{callbacks}->{$interface}->{$name} = $code; } =item $object->connect_to_signal($name, $coderef); Connects a callback to a signal emitted by the object. The C<$name> parameter is the name of the signal within the object, and C<$coderef> is a reference to an anonymous subroutine. When the signal C<$name> is emitted by the remote object, the subroutine C<$coderef> will be invoked, and passed the parameters from the signal. =cut sub connect_to_signal { my $self = shift; my $name = shift; my $code = shift; my $ins = $self->_introspector; if (!$ins) { die "no introspection data available for '" . $self->get_object_path . "', use the connect_to_signal_in method instead"; } my @interfaces = $ins->has_signal($name); if ($#interfaces == -1) { die "no signal with name '$name' is exported in object '" . $self->get_object_path . "'\n"; } elsif ($#interfaces > 0) { die "signal with name '$name' is exported " . "in multiple interfaces of '" . $self->get_object_path . "'" . "use the connect_to_signal_in method instead"; } $self->connect_to_signal_in($name, $interfaces[0], $code); } sub _dispatch { my $self = shift; my $connection = shift; my $message = shift; # Experiment in handling dispatch for child objects internally # my $path = $message->get_path; # while ($path ne $self->get_object_path) { # if (exists $self->{children}->{$path}) { # $self->{children}->{$path}->_dispatch($connection, $message); # return; # } # $path =~ s,/[^/]+$,,; # } my $reply; my $method_name = $message->get_member; my $interface = $message->get_interface; if ((defined $interface) && ($interface eq "org.freedesktop.DBus.Introspectable")) { if ($method_name eq "Introspect" && $self->_introspector && $ENABLE_INTROSPECT) { my $xml = $self->_introspector->format($self); $reply = $connection->make_method_return_message($message); $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml); } } elsif ((defined $interface) && ($interface eq "org.freedesktop.DBus.Properties")) { if ($method_name eq "Get") { $reply = $self->_dispatch_prop_read($connection, $message); } elsif ($method_name eq "GetAll") { $reply = $self->_dispatch_all_prop_read($connection, $message); } elsif ($method_name eq "Set") { $reply = $self->_dispatch_prop_write($connection, $message); } } elsif ($self->_is_method_allowed($method_name)) { my $ins = $self->_introspector; my @ret = eval { my @args; if ($ins) { @args = $ins->decode($message, "methods", $method_name, "params"); } else { @args = $message->get_args_list; } $self->$method_name(@args); }; if ($@) { my $name = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->name : "org.freedesktop.DBus.Error.Failed"; my $desc = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->message : $@; $reply = $connection->make_error_message($message, $name, $desc); } else { $reply = $connection->make_method_return_message($message); if ($ins) { $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret); } else { $reply->append_args_list(@ret); } } } if (!$reply) { $reply = $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "No such method " . ref($self) . "->" . $method_name); } if ($message->get_no_reply()) { # Not sending reply } else { $self->get_service->get_bus->get_connection->send($reply); } } sub _dispatch_prop_read { my $self = shift; my $connection = shift; my $message = shift; my $ins = $self->_introspector; if (!$ins) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no introspection data exported for properties"); } my ($pinterface, $pname) = $ins->decode($message, "methods", "Get", "params"); if (!$ins->has_property($pname, $pinterface)) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no property '$pname' exported in interface '$pinterface'"); } if (!$ins->is_property_readable($pinterface, $pname)) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "property '$pname' in interface '$pinterface' is not readable"); } if ($self->can($pname)) { my $value = eval { $self->$pname; }; if ($@) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "error reading '$pname' in interface '$pinterface': $@"); } else { my $reply = $connection->make_method_return_message($message); $self->_introspector->encode($reply, "methods", "Get", "returns", $value); return $reply; } } else { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no method to read property '$pname' in interface '$pinterface'"); } } sub _dispatch_all_prop_read { my $self = shift; my $connection = shift; my $message = shift; my $ins = $self->_introspector; if (!$ins) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no introspection data exported for properties"); } my ($pinterface) = $ins->decode($message, "methods", "Get", "params"); my %values = (); foreach my $pname ($ins->list_properties($pinterface)) { unless ($ins->is_property_readable($pinterface, $pname)) { next; # skip write-only properties } $values{$pname} = eval { $self->$pname; }; if ($@) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "error reading '$pname' in interface '$pinterface': $@"); } } my $reply = $connection->make_method_return_message($message); $self->_introspector->encode($reply, "methods", "Get", "returns", \%values); return $reply; } sub _dispatch_prop_write { my $self = shift; my $connection = shift; my $message = shift; my $ins = $self->_introspector; if (!$ins) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no introspection data exported for properties"); } my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "Set", "params"); if (!$ins->has_property($pname, $pinterface)) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no property '$pname' exported in interface '$pinterface'"); } if (!$ins->is_property_writable($pinterface, $pname)) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "property '$pname' in interface '$pinterface' is not writable"); } if ($self->can($pname)) { eval { $self->$pname($pvalue); }; if ($@) { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "error writing '$pname' in interface '$pinterface': $@"); } else { return $connection->make_method_return_message($message); } } else { return $connection->make_error_message($message, "org.freedesktop.DBus.Error.Failed", "no method to write property '$pname' in interface '$pinterface'"); } } sub _introspector { my $self = shift; if (!$self->{introspected}) { $self->{introspector} = Net::DBus::Exporter::_dbus_introspector(ref($self)); $self->{introspected} = 1; } return $self->{introspector}; } sub _is_method_allowed { my $self = shift; my $method = shift; # Disallow any method defined in this specific package, since these # are all server-side helpers / internal methods return 0 if __PACKAGE__->can($method); # If this object instance doesn't have it defined, trivially can't # allow it return 0 unless $self->can($method); my $ins = $self->_introspector; if (defined $ins) { # Finally do check against introspection data return $ins->is_method_allowed($method); } # No introspector, so have to assume its allowed return 1; } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L, L. =cut Net-DBus-1.0.0/lib/Net/DBus/Callback.pm0000644000076500007650000000706511603165524017435 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Callback - a callback for receiving reactor events =head1 SYNOPSIS use Net::DBus::Callback; # Assume we have a 'terminal' object and its got a method # to be invoked everytime there is input on its terminal. # # To create a callback to invoke this method one might use my $cb = Net::DBus::Callback->new(object => $terminal, method => "handle_stdio"); # Whatever is monitoring the stdio channel, would then # invoke the callback, perhaps passing in a parameter with # some 'interesting' data, such as number of bytes available $cb->invoke($nbytes) #... which results in a call to # $terminal->handle_stdio($nbytes) =head1 DESCRIPTION This module provides a simple container for storing details about a callback to be invoked at a later date. It is used when registering to receive events from the L class. NB use of this module in application code is no longer neccessary and it remains purely for backwards compatability. Instead you can simply pass a subroutine code reference in any place where a callback is desired. =head1 METHODS =over 4 =cut package Net::DBus::Callback; use 5.006; use strict; use warnings; =item my $cb = Net::DBus::Callback->new(method => $name, [args => \@args]) Creates a new callback object, for invoking a plain old function. The C parameter should be the fully qualified function name to invoke, including the package name. The optional C parameter is an array reference of parameters to be pass to the callback, in addition to those passed into the C method. =item my $cb = Net::DBus::Callback->new(object => $object, method => $name, [args => \@args]) Creates a new callback object, for invoking a method on an object. The C parameter should be the name of the method to invoke, while the C parameter should be a blessed object on which the method will be invoked. The optional C parameter is an array reference of parameters to be pass to the callback, in addition to those passed into the C method. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{object} = $params{object} ? $params{object} : undef; $self->{method} = $params{method} ? $params{method} : die "method parameter is required"; $self->{args} = $params{args} ? $params{args} : []; bless $self, $class; return $self; } =item $cb->invoke(@args) Invokes the callback. The argument list passed to the callback is a combination of the arguments supplied in the callback constructor, followed by the arguments supplied in the C method. =cut sub invoke { my $self = shift; if ($self->{object}) { my $obj = $self->{object}; my $method = $self->{method}; $obj->$method(@{$self->{args}}, @_); } else { my $method = $self->{method}; &$method(@{$self->{args}}, @_); } } 1; __END__ =back =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Tutorial/0000755000076500007650000000000011603165554017201 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/Tutorial/ExportingObjects.pod0000644000076500007650000003067111603165524023202 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2005 Daniel P. Berrange # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # $Id: ExportingObjects.pod,v 1.1 2006/01/27 14:02:35 dan Exp $ =pod =head1 NAME Net::DBus::Tutorial::ExportingObjects - tutorials on providing a DBus service =head1 DESCRIPTION This document provides a tutorial on providing a DBus service using the Perl Net::DBus application bindings. This examples in this document will be based on the code from the L distribution, which is a simple DBus service providing a music track player. =head1 CREATING AN OBJECT The first step in creating an object is to create a new package which inherits from L. The Music::Player::Manager object provides an API for managing the collection of music player backends for different track types. To start with, lets create the skeleton of the package & its constructor. The constructor of the super type, L expects to be given to parameters, a handle to the L owning the object, and a path under which the object shall be exported. Since the manager class is intended to be a singleton object, we can hard code the path to it within the constructor: package Music::Player::Manager; use base qw(Net::DBus); sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/music/player/manager"); bless $self, $class; return $self; } 1; Now, as mentioned, the manager with handle a number of different player backends. So we need to provide methods for registering new backends, and querying for backends capable of playing a particular file type. So modifying the above code we add a hash table in the constructor, to store the backends: sub new { my $class = shift; my $service = shift; my $self = $class->SUPER::new($service, "/music/player/manager"); $self->{backends} = {}; bless $self, $class; return $self; } And now a method to register a new backend. This takes a Perl module name and uses it to instantiate a backend. Since the backends are also going to be DBus objects, we need to pass in a reference to the service we are attached to, along with a path under which to register the backend. We use the C method to retreieve a reference to the service the manager is attached to, and attach the player backend to this same service: When a method on DBus object is invoked, the first parameter is the object reference (C<$self>), and the remainder are the parameters provided to the method call. Thus writing a method implementation on a DBUs is really no different to normal object oriented Perl (cf L): sub register_backend { my $self = shift; my $name = shift; my $module = shift; eval "use $module"; if ($@) { die "cannot load backend $module: $@" ; } $self->{backends} = $module->new($self->get_service, "/music/player/backend/$name"); } Looking at this one might wonder what happens if the C method is triggered. In such a scenario, rather than terminating the service process, the error will be caught and propagated back to the remote caller to deal with. The player backends provide a method C which returns an array reference of the music track types they support. We can use this method to provide an API to allow easy retrieval of a backend for a particular track type. This method will return a path with which the backend object can be accessed sub find_backend { my $self = shift; my $extension = shift; foreach my $name (keys %{$self->{backends}}) { my $backend = $self->{backends}->{$name}; foreach my $type (@{$backend->get_track_types}) { if ($type eq $extension) { return $backend->get_object_path; } } } die "no backend for type $extension"; } Lets take a quick moment to consider how this method would be used to play a music track. If you've not already done so, refresh your memory from L. Now, we have an MP3 file which we wish to play, so we search for the path to a backend, then retrieve the object for it, and play the track: ...get the music player service... # Ask for a path to a player for mp3 files my $path = $service->find_backend("mp3"); # $path now contains '/music/player/backend/mpg123' # and we can get the backend object my $backend = $service->get_object($path); # and finally play the track $backend->play("/vol/music/beck/guero/09-scarecrow.mp3"); =head1 PROVIDING INTROSPECTION DATA The code above is a complete working object, ready to be registered with a service, and since the parameters and return values for the two methods are both simple strings we could stop there. In some cases, however, one might want to be more specific about data types expected for parameters, for example signed vs unsigned integers. Adding explicit data typing also makes interaction with other programming languages more reliable. Providing explicit data type defintions for exported method is known in the DBus world as C, and it makes life much more reliable for users of one's service whom may be using a strongly typed language such as C. The first step in providing introspection data for a DBus object in Perl, is to specify the name of the interface provided by the object. This is typically a period separated string, by convention containing the domain name of the application as its first component. Since most Perl modules end up living on CPAN, one might use C as the first component, followed by the package name of the module (replacing :: with .), eg C. If it is not planned to host the module on CPAN, a personal/project domain might be used eg C. The interface for an object is defined by loading the L module, providing the interface as its first parameter. So the earlier code example would be modified to look like: package Music::Player::Manager; use base qw(Net::DBus); use Net::DBus::Exporter qw(com.berrange.music.player.manager) Next up, it is neccessary to provide data types for the parameters and return values of the methods. The L module provides a method C for this purpose, which takes three parameter, the name of the method being exported, an array reference of parameter types, and an array reference of return types (the latter can be omitted if there are no return values). This can be called at any point in the module's code, but by convention it is preferrable to associate calls to C with the actual method implementation, thus: dbus_method("register_backend", ["string", "string"]); sub register_backend { my $self = shift; my $name = shift; my $module = shift; .. snipped rest of method body ... } And, thus: dbus_method("find_backend", ["string"], ["string"]) sub find_backend { my $self = shift; my $extension = shift; ... snip method body... } =head1 DEFINING A SERVICE Now that the objects have been written, it is time to define a service. A service is nothing more than a well known name for a given API contract. A contract can be thought of as a definition of a list of object paths, and the corresponding interfaces they provide. So, someone else could come along a provide an alternate music player implementation using the Python or QT bindings for DBus, and if they provided the same set of object paths & interfaces, they could justifiably register the same service on the bus. The L module provides the means to register a service. Its constructor expects a reference to the bus object (an instance of L), along with the name of the service. As with interface names, the first component of a service name is usually derived from a domain name, and then suffixed with the name of the application, in our example forming C. While some objects will be created on the fly during execution of the application, others are created upon initial startup. The music player manager object created earlier in this tutorial is an example of the latter. It is typical to instantiate and register these objects in the constructor for the service. Thus a service object for the music player application would look like: package Music::Player; use base qw(Net::DBus::Service); sub new { my $class = shift; my $bus = shift; my $self = $class->SUPER::new($bus, "org.cpan.music.player"); bless $self, $class; $self->{manager} = Music::Player::Manager->new($self); return $self; } The L automatically provides one special object to all services, under the path C. This object implements the C interface which has a method C. This enables clients to determine a list of all objects exported within a service. While not functionally neccessary for most applications, it is none-the-less a useful tool for developers debugging applications, or wondering what a service provides. =head1 CONNECTING TO THE BUS The final step in getting our service up and running is to connect it to the bus. This brings up an interesting conundrum, does one export the service on the system bus (shared by all users & processes on the machine), or the session bus (one per user logged into a machine). In some cases the answer, with only one of the two buses conceptually making sense. In other cases, however, both the session & system bus are valid. In the former one would use the C or methods on L to get a handle to the desired bus, while in the latter case, the C method would be used. This applies a heuristic to determine the correct bus based on execution environment. In the case of the music player, either bus is relevant, so the code to connect the service to the bus would look like: use Net::DBus; my $bus = Net::DBus->find; my $player = Music::Player->new($bus); With the service attached to the bus, it is merely neccessary to run the main event processing loop to listen out for & handle incoming DBus messages. So the above code is modified to start a simple reactor: use Net::DBus; use Net::DBus::Reactor; my $bus = Net::DBus->find; my $player = Music::Player->new($bus); Net::DBus::Reactor->main->run; exit 0; Saving this code into a script C, coding is complete and the service ready for use by clients on the bus. =head1 SERVICE ACTIVATION One might now wonder how best to start the service, particularly if it is a service capable of running on both the system and session buses. DBus has the answer in the concept of C. What happens is that when a client on the bus attempts to call a method, or register a signal handler against, a service not currently running, it will first try and start the service. Service's which wish to participate in this process merely need stick a simple service definition file into the directoy C. The file should be named to match the service name, with the file extension C<.service> appended. eg, C The file contains two keys, first the name of the service, and second the name of the executable used to run the service, or in this case the Perl script. So, for our simple service the data file would contain: [D-BUS Service] Name=org.cpan.music.player Exec=/usr/bin/music-player.pl =head1 SEE ALSO L for details of other tutorials, and L for API documentation =head1 AUTHORS Daniel Berrange =head1 COPYRIGHT Copyright (C) 2005 Daniel P. Berrange =cut Net-DBus-1.0.0/lib/Net/DBus/Tutorial/UsingObjects.pod0000644000076500007650000000243111603165524022301 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2005 Daniel P. Berrange # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # $Id: UsingObjects.pod,v 1.1 2006/02/03 13:34:18 dan Exp $ =pod =head1 NAME Net::DBus::Tutorial::UsingObjects - tutorial on accessing a DBus service =head1 DESCRIPTION This document provides a tutorial on accessing a DBus service using the Perl Net::DBus application bindings. Sadly it is not yet written. =head1 SEE ALSO L for details of other tutorials, and L for API documentation =head1 AUTHORS Daniel Berrange =head1 COPYRIGHT Copyright (C) 2006 Daniel P. Berrange =cut Net-DBus-1.0.0/lib/Net/DBus/Reactor.pm0000644000076500007650000004422111603165524017333 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Reactor - application event loop =head1 SYNOPSIS Create and run an event loop: use Net::DBus::Reactor; my $reactor = Net::DBus::Reactor->main(); $reactor->run(); Manage some file handlers $reactor->add_read($fd, Net::DBus::Callback->new(method => sub { my $fd = shift; ...read some data... }, args => [$fd])); $reactor->add_write($fd, Net::DBus::Callback->new(method => sub { my $fd = shift; ...write some data... }, args => [$fd])); Temporarily (dis|en)able a handle # Disable $reactor->toggle_read($fd, 0); # Enable $reactor->toggle_read($fd, 1); Permanently remove a handle $reactor->remove_read($fd); Manage a regular timeout every 100 milliseconds my $timer = $reactor->add_timeout(100, Net::DBus::Callback->new( method => sub { ...process the alarm... })); Temporarily (dis|en)able a timer # Disable $reactor->toggle_timeout($timer, 0); # Enable $reactor->toggle_timeout($timer, 1); Permanently remove a timer $reactor->remove_timeout($timer); Add a post-dispatch hook my $hook = $reactor->add_hook(Net::DBus::Callback->new( method => sub { ... do some work... })); Remove a hook $reactor->remove_hook($hook); =head1 DESCRIPTION This class provides a general purpose event loop for the purposes of multiplexing I/O events and timeouts in a single process. The underlying implementation is done using the select system call. File handles can be registered for monitoring on read, write and exception (out-of-band data) events. Timers can be registered to expire with a periodic frequency. These are implemented using the timeout parameter of the select system call. Since this parameter merely represents an upper bound on the amount of time the select system call is allowed to sleep, the actual period of the timers may vary. Under normal load this variance is typically 10 milliseconds. Finally, hooks may be registered which will be invoked on each iteration of the event loop (ie after processing the file events, or timeouts indicated by the select system call returning). =head1 METHODS =over 4 =cut package Net::DBus::Reactor; use 5.006; use strict; use warnings; use Net::DBus::Binding::Watch; use Net::DBus::Callback; use Time::HiRes qw(gettimeofday); =item my $reactor = Net::DBus::Reactor->new(); Creates a new event loop ready for monitoring file handles, or generating timeouts. Except in very unsual circumstances (examples of which I can't think up) it is not neccessary or desriable to explicitly create new reactor instances. Instead call the L
method to get a handle to the singleton instance. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{fds} = { read => {}, write => {}, exception => {} }; $self->{timeouts} = []; $self->{hooks} = []; bless $self, $class; return $self; } use vars qw($main_reactor); =item $reactor = Net::DBus::Reactor->main; Return a handle to the singleton instance of the reactor. This is the recommended way of getting hold of a reactor, since it removes the need for modules to pass around handles to their privately created reactors. =cut sub main { my $class = shift; $main_reactor = $class->new() unless defined $main_reactor; return $main_reactor; } =item $reactor->manage($connection); =item $reactor->manage($server); Registers a C or C object for management by the event loop. This basically involves hooking up the watch & timeout callbacks to the event loop. For connections it will also register a hook to invoke the C method periodically. =cut sub manage { my $self = shift; my $object = shift; if ($object->can("set_watch_callbacks")) { $object->set_watch_callbacks(sub { my $object = shift; my $watch = shift; $self->_manage_watch_on($object, $watch); }, sub { my $object = shift; my $watch = shift; $self->_manage_watch_off($object, $watch); }, sub { my $object = shift; my $watch = shift; $self->_manage_watch_toggle($object, $watch); }); } if ($object->can("set_timeout_callbacks")) { $object->set_timeout_callbacks(sub { my $object = shift; my $timeout = shift; my $key = $self->add_timeout($timeout->get_interval, Net::DBus::Callback->new(object => $timeout, method => "handle", args => []), $timeout->is_enabled); $timeout->set_data($key); }, sub { my $object = shift; my $timeout = shift; my $key = $timeout->get_data; $self->remove_timeout($key); }, sub { my $object = shift; my $timeout = shift; my $key = $timeout->get_data; $self->remove_timeout($key, $timeout->is_enabled, $timeout->get_interval); }); } if ($object->can("dispatch")) { $self->add_hook(Net::DBus::Callback->new(object => $object, method => "dispatch", args => []), 1); } if ($object->can("flush")) { $self->add_hook(Net::DBus::Callback->new(object => $object, method => "flush", args => []), 1); } } sub _manage_watch_on { my $self = shift; my $object = shift; my $watch = shift; my $flags = $watch->get_flags; if ($flags & &Net::DBus::Binding::Watch::READABLE) { $self->add_read($watch->get_fileno, Net::DBus::Callback->new(object => $watch, method => "handle", args => [&Net::DBus::Binding::Watch::READABLE]), $watch->is_enabled); } if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { $self->add_write($watch->get_fileno, Net::DBus::Callback->new(object => $watch, method => "handle", args => [&Net::DBus::Binding::Watch::WRITABLE]), $watch->is_enabled); } # $self->add_exception($watch->get_fileno, $watch, # Net::DBus::Callback->new(object => $watch, # method => "handle", # args => [&Net::DBus::Binding::Watch::ERROR]), # $watch->is_enabled); } sub _manage_watch_off { my $self = shift; my $object = shift; my $watch = shift; my $flags = $watch->get_flags; if ($flags & &Net::DBus::Binding::Watch::READABLE) { $self->remove_read($watch->get_fileno); } if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { $self->remove_write($watch->get_fileno); } # $self->remove_exception($watch->get_fileno); } sub _manage_watch_toggle { my $self = shift; my $object = shift; my $watch = shift; my $flags = $watch->get_flags; if ($flags & &Net::DBus::Binding::Watch::READABLE) { $self->toggle_read($watch->get_fileno, $watch->is_enabled); } if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { $self->toggle_write($watch->get_fileno, $watch->is_enabled); } $self->toggle_exception($watch->get_fileno, $watch->is_enabled); } =item $reactor->run(); Starts the event loop monitoring any registered file handles and timeouts. At least one file handle, or timer must have been registered prior to running the reactor, otherwise it will immediately exit. The reactor will run until all registered file handles, or timeouts have been removed, or disabled. The reactor can be explicitly stopped by calling the C method. =cut sub run { my $self = shift; $self->{running} = 1; while ($self->{running}) { $self->step }; } =item $reactor->shutdown(); Explicitly shutdown the reactor after pending events have been processed. =cut sub shutdown { my $self = shift; $self->{running} = 0; } =item $reactor->step(); Perform one iteration of the event loop, going to sleep until an event occurs on a registered file handle, or a timeout occurrs. This method is generally not required in day-to-day use. =cut sub step { my $self = shift; my @callbacks = $self->_dispatch_hook(); foreach my $callback (@callbacks) { $callback->invoke; } my ($ri, $ric) = $self->_bits("read"); my ($wi, $wic) = $self->_bits("write"); my ($ei, $eic) = $self->_bits("exception"); my $timeout = $self->_timeout($self->_now); if (!$ric && !$wic && !$eic && !(defined $timeout)) { $self->{running} = 0; } # One of the hooks we ran might have requested shutdown # so check here to avoid a undesirable wait in select() # cf RT #39068 return unless $self->{running}; my ($ro, $wo, $eo); my $n = select($ro=$ri,$wo=$wi,$eo=$ei, (defined $timeout ? ($timeout ? $timeout/1000 : 0) : undef)); @callbacks = (); if ($n) { push @callbacks, $self->_dispatch_fd("read", $ro); push @callbacks, $self->_dispatch_fd("write", $wo); push @callbacks, $self->_dispatch_fd("error", $eo); } push @callbacks, $self->_dispatch_timeout($self->_now); #push @callbacks, $self->_dispatch_hook(); foreach my $callback (@callbacks) { $callback->invoke; } return 1; } sub _now { my $self = shift; my @now = gettimeofday; return $now[0] * 1000 + (($now[1] - ($now[1] % 1000)) / 1000); } sub _bits { my $self = shift; my $type = shift; my $vec = ''; my $count = 0; foreach (keys %{$self->{fds}->{$type}}) { next unless $self->{fds}->{$type}->{$_}->{enabled}; $count++; vec($vec, $_, 1) = 1; } return ($vec, $count); } sub _timeout { my $self = shift; my $now = shift; my $timeout; foreach (@{$self->{timeouts}}) { next unless $_->{enabled}; my $expired = $now - $_->{last_fired}; my $interval = ($expired > $_->{interval} ? 0 : $_->{interval} - $expired); $timeout = $interval if !(defined $timeout) || ($interval < $timeout); } return $timeout; } sub _dispatch_fd { my $self = shift; my $type = shift; my $vec = shift; my @callbacks; foreach my $fd (keys %{$self->{fds}->{$type}}) { next unless $self->{fds}->{$type}->{$fd}->{enabled}; if (vec($vec, $fd, 1)) { my $rec = $self->{fds}->{$type}->{$fd}; push @callbacks, $self->{fds}->{$type}->{$fd}->{callback}; } } return @callbacks; } sub _dispatch_timeout { my $self = shift; my $now = shift; my @callbacks; foreach my $timeout (@{$self->{timeouts}}) { next unless $timeout->{enabled}; my $expired = $now - $timeout->{last_fired}; # Select typically returns a little (0-10 ms) before we # asked it for. (8 milliseconds seems reasonable balance # between early timeouts & extra select calls if ($expired >= ($timeout->{interval}-8)) { $timeout->{last_fired} = $now; push @callbacks, $timeout->{callback}; } } return @callbacks; } sub _dispatch_hook { my $self = shift; my $now = shift; my @callbacks; foreach my $hook (@{$self->{hooks}}) { next unless $hook->{enabled}; push @callbacks, $hook->{callback}; } return @callbacks; } =item $reactor->add_read($fd, $callback[, $status]); Registers a file handle for monitoring of read events. The C<$callback> parameter specifies either a code reference to a subroutine, or an instance of the C object to invoke each time an event occurs. The optional C<$status> parameter is a boolean value to specify whether the watch is initially enabled. =cut sub add_read { my $self = shift; $self->_add("read", @_); } =item $reactor->add_write($fd, $callback[, $status]); Registers a file handle for monitoring of write events. The C<$callback> parameter specifies either a code reference to a subroutine, or an instance of the C object to invoke each time an event occurs. The optional C<$status> parameter is a boolean value to specify whether the watch is initially enabled. =cut sub add_write { my $self = shift; $self->_add("write", @_); } =item $reactor->add_exception($fd, $callback[, $status]); Registers a file handle for monitoring of exception events. The C<$callback> parameter specifies either a code reference to a subroutine, or an instance of the C object to invoke each time an event occurs. The optional C<$status> parameter is a boolean value to specify whether the watch is initially enabled. =cut sub add_exception { my $self = shift; $self->_add("exception", @_); } =item my $id = $reactor->add_timeout($interval, $callback, $status); Registers a new timeout to expire every C<$interval> milliseconds. The C<$callback> parameter specifies either a code reference to a subroutine, or an instance of the C object to invoke each time the timeout expires. The optional C<$status> parameter is a boolean value to specify whether the timeout is initially enabled. The return parameter is a unique identifier which can be used to later remove or disable the timeout. =cut sub add_timeout { my $self = shift; my $interval = shift; my $callback = shift; my $enabled = shift; $enabled = 1 unless defined $enabled; if (ref($callback) eq "CODE") { $callback = Net::DBus::Callback->new(method => $callback); } my $key; for (my $i = 0 ; $i <= $#{$self->{timeouts}} && !(defined $key); $i++) { $key = $i unless defined $self->{timeouts}->[$i]; } $key = $#{$self->{timeouts}}+1 unless defined $key; $self->{timeouts}->[$key] = { interval => $interval, last_fired => $self->_now, callback => $callback, enabled => $enabled }; return $key; } =item $reactor->remove_timeout($id); Removes a previously registered timeout specified by the C<$id> parameter. =cut sub remove_timeout { my $self = shift; my $key = shift; die "no timeout active with key '$key'" unless defined $self->{timeouts}->[$key]; $self->{timeouts}->[$key] = undef; } =item $reactor->toggle_timeout($id, $status[, $interval]); Updates the state of a previously registered timeout specifed by the C<$id> parameter. The C<$status> parameter specifies whether the timeout is to be enabled or disabled, while the optional C<$interval> parameter can be used to change the period of the timeout. =cut sub toggle_timeout { my $self = shift; my $key = shift; my $enabled = shift; $self->{timeouts}->[$key]->{enabled} = $enabled; $self->{timeouts}->[$key]->{interval} = shift if @_; } =item my $id = $reactor->add_hook($callback[, $status]); Registers a new hook to be fired on each iteration of the event loop. The C<$callback> parameter specifies either a code reference to a subroutine, or an instance of the C class to invoke. The C<$status> parameter determines whether the hook is initially enabled, or disabled. The return parameter is a unique id which should be used to later remove, or disable the hook. =cut sub add_hook { my $self = shift; my $callback = shift; my $enabled = shift; $enabled = 1 unless defined $enabled; if (ref($callback) eq "CODE") { $callback = Net::DBus::Callback->new(method => $callback); } my $key; for (my $i = 0 ; $i <= $#{$self->{hooks}} && !(defined $key); $i++) { $key = $i unless defined $self->{hooks}->[$i]; } $key = $#{$self->{hooks}}+1 unless defined $key; $self->{hooks}->[$key] = { callback => $callback, enabled => $enabled }; return $key; } =item $reactor->remove_hook($id) Removes the previously registered hook identified by C<$id>. =cut sub remove_hook { my $self = shift; my $key = shift; die "no hook present with key '$key'" unless defined $self->{hooks}->[$key]; $self->{hooks}->[$key] = undef; } =item $reactor->toggle_hook($id, $status) Updates the status of the previously registered hook identified by C<$id>. The C<$status> parameter determines whether the hook is to be enabled or disabled. =cut sub toggle_hook { my $self = shift; my $key = shift; my $enabled = shift; $self->{hooks}->[$key]->{enabled} = $enabled; } sub _add { my $self = shift; my $type = shift; my $fd = shift; my $callback = shift; my $enabled = shift; $enabled = 1 unless defined $enabled; if (ref($callback) eq "CODE") { $callback = Net::DBus::Callback->new(method => $callback); } $self->{fds}->{$type}->{$fd} = { callback => $callback, enabled => $enabled }; } =item $reactor->remove_read($fd); =item $reactor->remove_write($fd); =item $reactor->remove_exception($fd); Removes a watch on the file handle C<$fd>. =cut sub remove_read { my $self = shift; $self->_remove("read", @_); } sub remove_write { my $self = shift; $self->_remove("write", @_); } sub remove_exception { my $self = shift; $self->_remove("exception", @_); } sub _remove { my $self = shift; my $type = shift; my $fd = shift; die "no handle ($type) active with fd '$fd'" unless exists $self->{fds}->{$type}->{$fd}; delete $self->{fds}->{$type}->{$fd}; } =item $reactor->toggle_read($fd, $status); =item $reactor->toggle_write($fd, $status); =item $reactor->toggle_exception($fd, $status); Updates the status of a watch on the file handle C<$fd>. The C<$status> parameter species whether the watch is to be enabled or disabled. =cut sub toggle_read { my $self = shift; $self->_toggle("read", @_); } sub toggle_write { my $self = shift; $self->_toggle("write", @_); } sub toggle_exception { my $self = shift; $self->_toggle("exception", @_); } sub _toggle { my $self = shift; my $type = shift; my $fd = shift; my $enabled = shift; $self->{fds}->{$type}->{$fd}->{enabled} = $enabled; } 1; =pod =back =head1 SEE ALSO L, L, L =head1 AUTHOR Daniel Berrange Edan@berrange.comE =head1 COPYRIGHT Copyright 2004-2011 by Daniel Berrange =cut Net-DBus-1.0.0/lib/Net/DBus/Tutorial.pod0000644000076500007650000000364411603165524017711 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2005 Daniel P. Berrange # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # $Id: Tutorial.pod,v 1.2 2006/02/03 13:34:18 dan Exp $ =pod =head1 NAME Net::DBus::Tutorial - tutorials on the Perl DBus APIs =head1 DESCRIPTION This section includes tutorials on the Perl DBus APIs. Current topics include providing a service, by exporting objects to the bus, and accessing a service, by calling objects on the bus. =over 4 =item L This tutorial covers how to provide a service to the bus by exporting objects. The topics covered include basics of creating objects and methods, emitting signals, exporting properties, registering services for automatic activation. =item L This tutorial cover how to use a service provided on the bus by another application. The topics covered include the basics of calling methods on remote objects, explicitly calling methods in particular interfaces, listening for signals. NB This tutorial is yet to be written. =back =head1 SEE ALSO L, L, L, L =head1 AUTHORS Daniel P. Berrange L =head1 COPYRIGHT Copyright 2005 Daniel P. Berrange =cut Net-DBus-1.0.0/lib/Net/DBus/RemoteService.pm0000644000076500007650000000762711603165524020521 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::RemoteService - Access services provided on the bus =head1 SYNOPSIS my $bus = Net::DBus->find; my $service = $bus->get_service("org.freedesktop.DBus"); my $object = $service->get_object("/org/freedesktop/DBus"); foreach (@{$object->ListNames}) { print "$_\n"; } =head1 DESCRIPTION This object provides a handle to a remote service on the bus. From this handle it is possible to access objects associated with the service. If a service is not running, an attempt will be made to activate it the first time a method is called against one of its objects. =head1 METHODS =over 4 =cut package Net::DBus::RemoteService; use 5.006; use strict; use warnings; use Net::DBus::RemoteObject; =item my $service = Net::DBus::RemoteService->new($bus, $owner, $service_name); Creates a new handle for a remote service. The C<$bus> parameter is an instance of L, C<$owner> is the name of the client providing the service, while C<$service_name> is the well known name of the service on the bus. Service names consist of two or more tokens, separated by periods, while the tokens comprise the letters a-z, A-Z, 0-9 and _, for example C. There is generally no need to call this constructor, instead the C method on L should be used. This caches handles to remote services, eliminating repeated retrieval of introspection data. =cut sub new { my $class = shift; my $self = {}; $self->{bus} = shift; $self->{owner_name} = shift; $self->{service_name} = shift; $self->{objects} = {}; bless $self, $class; return $self; } =item my $bus = $service->get_bus; Retrieves a handle for the bus to which this service is attached. The returned object will be an instance of L. =cut sub get_bus { my $self = shift; return $self->{bus}; } =item my $service_name = $service->get_service_name Retrieves the name of the remote service as known to the bus. =cut sub get_service_name { my $self = shift; return $self->{service_name}; } =item my $owner_name = $service->get_owner_name; Retrieves the name of the client owning the service at the time it was connected to. =cut sub get_owner_name { my $self = shift; return $self->{owner_name}; } =item my $object = $service->get_object($object_path[, $interface]); Retrieves a handle to the remote object provided by the service with the name of C<$object_path>. If the optional C<$interface> parameter is provided, the object will immediately be cast to the designated interface. NB, it is only neccessary to cast an object to a specific interface if there are multiple interfaces on the object providing methods with the same name, or the remote object does support introspection. The returned object will be an instance of L. =cut sub get_object { my $self = shift; my $object_path = shift; unless (defined $self->{objects}->{$object_path}) { $self->{objects}->{$object_path} = Net::DBus::RemoteObject->new($self, $object_path); } if (@_) { my $interface = shift; return $self->{objects}->{$object_path}->as_interface($interface); } else { return $self->{objects}->{$object_path}; } } 1; =pod =back =head1 AUTHOR Daniel Berrange =head1 COPYRIGHT Copright (C) 2004-2011, Daniel Berrange. =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Service.pm0000644000076500007650000000573011603165524017336 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Service - Provide a service to the bus for clients to use =head1 SYNOPSIS package main; use Net::DBus; # Attach to the bus my $bus = Net::DBus->find; # Acquire a service 'org.demo.Hello' my $service = $bus->export_service("org.demo.Hello"); # Export our object within the service my $object = Demo::HelloWorld->new($service); ....rest of program... =head1 DESCRIPTION This module represents a service which is exported to the message bus. Once a service has been exported, it is possible to create and export objects to the bus. =head1 METHODS =over 4 =cut package Net::DBus::Service; use 5.006; use strict; use warnings; =item my $service = Net::DBus::Service->new($bus, $name); Create a new service, attaching to the bus provided in the C<$bus> parameter, which should be an instance of the L object. The C<$name> parameter is the qualified service name. It is not usually neccessary to use this constructor, since services can be created via the C method on the L object. =cut sub new { my $class = shift; my $self = {}; $self->{bus} = shift; $self->{service_name} = shift; $self->{objects} = {}; bless $self, $class; $self->get_bus->get_connection->request_name($self->get_service_name); return $self; } =item my $bus = $service->get_bus; Retrieves the L object to which this service is attached. =cut sub get_bus { my $self = shift; return $self->{bus}; } =item my $name = $service->get_service_name Retrieves the qualified name by which this service is known on the bus. =cut sub get_service_name { my $self = shift; return $self->{service_name}; } sub _register_object { my $self = shift; my $object = shift; #my $wildcard = shift || 0; # if ($wildcard) { # $self->get_bus->get_connection-> # register_fallback($object->get_object_path, # sub { # $object->_dispatch(@_); # }); # } else { $self->get_bus->get_connection-> register_object_path($object->get_object_path, sub { $object->_dispatch(@_); }); # } } sub _unregister_object { my $self = shift; my $object = shift; $self->get_bus->get_connection-> unregister_object_path($object->get_object_path); } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Dumper.pm0000644000076500007650000001407211603165524017171 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Dumper - Stringify Net::DBus objects suitable for printing =head1 SYNOPSIS use Net::DBus::Dumper; use Net::DBus; # Dump out info about the bus my $bus = Net::DBus->find; print dbus_dump($bus); # Dump out info about a service my $service = $bus->get_service("org.freedesktop.DBus"); print dbus_dump($service); # Dump out info about an object my $object = $service->get_object("/org/freedesktop/DBus"); print dbus_dump($object); =head1 DESCRIPTION This module serves as a debugging aid, providing a means to stringify a DBus related object in a form suitable for printing out. It can stringify any of the Net::DBus:* objects, generating the following information for each =over 4 =item Net::DBus A list of services registered with the bus =item Net::DBus::Service =item Net::DBus::RemoteService The service name =item Net::DBus::Object =item Net::DBus::RemoteObject The list of all exported methods, and signals, along with their parameter and return types. =back =head1 METHODS =over 4 =cut package Net::DBus::Dumper; use strict; use warnings; use base qw(Exporter); use vars qw(@EXPORT); @EXPORT = qw(dbus_dump); =item my @data = dbus_dump($object); Generates a stringified representation of an object. The object passed in as the parameter must be an instance of one of L, L, L, L, L. The stringified representation will be returned as a list of strings, with newlines in appropriate places, such that it can be passed string to the C method. =cut sub dbus_dump { my $object = shift; my $ref = ref($object); die "object '$object' is not a reference" unless defined $ref; if ($object->isa("Net::DBus::Object") || $object->isa("Net::DBus::RemoteObject")) { return &_dbus_dump_introspector($object->_introspector); } elsif ($object->isa("Net::DBus::RemoteService") || $object->isa("Net::DBus::Service")) { return &_dbus_dump_service($object); } elsif ($object->isa("Net::DBus")) { return &_dbus_dump_bus($object); } } sub _dbus_dump_introspector { my $ins = shift; my @data; push @data, "Object: ", $ins->get_object_path, "\n"; foreach my $interface (sort { $a cmp $b } $ins->list_interfaces) { push @data, " Interface: ", $interface, "\n"; foreach my $method (sort {$a cmp $b } $ins->list_methods($interface)) { push @data, " Method: ", $method, "\n"; my @paramnames = $ins->get_method_param_names($interface, $method); foreach my $param ($ins->get_method_params($interface, $method)) { my $name = @paramnames ? shift @paramnames : undef; push @data, &_dbus_dump_types(" > ", $param, $name); } my @returnnames = $ins->get_method_return_names($interface, $method); foreach my $param ($ins->get_method_returns($interface, $method)) { my $name = @returnnames ? shift @returnnames : undef; push @data, &_dbus_dump_types(" < ", $param, $name); } } foreach my $signal (sort { $a cmp $b } $ins->list_signals($interface)) { push @data, " Signal: ", $signal, "\n"; my @paramnames = $ins->get_signal_param_names($interface, $signal); foreach my $param ($ins->get_signal_params($interface, $signal)) { my $name = @paramnames ? shift @paramnames : undef; push @data, &_dbus_dump_types(" > ", $param, $name); } } foreach my $child (sort { $a cmp $b } $ins->list_children()) { push @data, " Child: ", $child, "\n"; } } return @data; } sub _dbus_dump_types { my $indent = shift; my $type = shift; my $name = shift; my @data; push @data, $indent; if (ref($type)) { push @data, $type->[0]; if (defined $name) { push @data, " ($name)"; } push @data, "\n"; for (my $i = 1 ; $i <= $#{$type} ; $i++) { push @data, &_dbus_dump_types($indent . " ", $type->[$i]); } } else { push @data, $type; if (defined $name) { push @data, " ($name)"; } push @data, "\n"; } return @data; } sub _dbus_dump_service { my $service = shift; my @data; push @data, "Service: ", $service->get_service_name, "\n"; my @objects = &_dbus_dump_children($service, "/"); foreach (@objects) { push @data, " Object: $_\n"; } return @data; } sub _dbus_dump_children { my $service = shift; my $path = shift; my $exp = $service->get_object($path); my @exports = eval { my $ins = $exp->_introspector; if ($ins) { return $ins->list_children; } return (); }; my @objects = map { $path eq "/" ? $path . $_ : $path . "/" . $_ } @exports; if ($@) { #push @objects, " Could not lookup objects under path '$path'\n"; } foreach my $child (@exports) { push @objects, _dbus_dump_children ($service, $path eq "/" ? $path . $child : $path . "/" . $child); } return @objects; } sub _dbus_dump_bus { my $bus = shift; my @data; push @data, "Bus: \n"; my $dbus = $bus->get_service("org.freedesktop.DBus"); my $obj = $dbus->get_object("/org/freedesktop/DBus"); my $names = $obj->ListNames(); foreach (sort { $a cmp $b } @{$names}) { push @data, " Service: ", $_, "\n"; } return @data; } 1; =pod =back =head1 BUGS It should print out a list of object paths registered against a service, but this only currently works for service implemented in Perl =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L, L, L, L. =cut Net-DBus-1.0.0/lib/Net/DBus/Exporter.pm0000644000076500007650000004176211603165524017553 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Exporter - Export object methods and signals to the bus =head1 SYNOPSIS # Define a new package for the object we're going # to export package Demo::HelloWorld; # Specify the main interface provided by our object use Net::DBus::Exporter qw(org.example.demo.Greeter); # We're going to be a DBus object use base qw(Net::DBus::Object); # Ensure only explicitly exported methods can be invoked dbus_strict_exports; # Export a 'Greeting' signal taking a stringl string parameter dbus_signal("Greeting", ["string"]); # Export 'Hello' as a method accepting a single string # parameter, and returning a single string value dbus_method("Hello", ["string"], ["string"]); # Export 'Goodbye' as a method accepting a single string # parameter, and returning a single string, but put it # in the 'org.exaple.demo.Farewell' interface dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell"); =head1 DESCRIPTION The C module is used to export methods and signals defined in an object to the message bus. Since Perl is a loosely typed language it is not possible to automatically determine correct type information for methods to be exported. Thus when sub-classing L, this package will provide the type information for methods and signals. When importing this package, an optional argument can be supplied to specify the default interface name to associate with methods and signals, for which an explicit interface is not specified. Thus in the common case of objects only providing a single interface, this removes the need to repeat the interface name against each method exported. =head1 SCALAR TYPES When specifying scalar data types for parameters and return values, the following string constants must be used to denote the data type. When values corresponding to these types are (un)marshalled they are represented as the Perl SCALAR data type (see L). =over 4 =item "string" A UTF-8 string of characters =item "int16" A 16-bit signed integer =item "uint16" A 16-bit unsigned integer =item "int32" A 32-bit signed integer =item "uint32" A 32-bit unsigned integer =item "int64" A 64-bit signed integer. NB, this type is not supported by many builds of Perl on 32-bit platforms, so if used, your data is liable to be truncated at 32-bits. =item "uint64" A 64-bit unsigned integer. NB, this type is not supported by many builds of Perl on 32-bit platforms, so if used, your data is liable to be truncated at 32-bits. =item "byte" A single 8-bit byte =item "bool" A boolean value =item "double" An IEEE double-precision floating point =back =head1 COMPOUND TYPES When specifying compound data types for parameters and return values, an array reference must be used, with the first element being the name of the compound type. =over 4 =item ["array", ARRAY-TYPE] An array of values, whose type os C. The C can be either a scalar type name, or a nested compound type. When values corresponding to the array type are (un)marshalled, they are represented as the Perl ARRAY data type (see L). If, for example, a method was declared to have a single parameter with the type, ["array", "string"], then when calling the method one would provide a array reference of strings: $object->hello(["John", "Doe"]) =item ["dict", KEY-TYPE, VALUE-TYPE] A dictionary of values, more commonly known as a hash table. The C is the name of the scalar data type used for the dictionary keys. The C is the name of the scalar, or compound data type used for the dictionary values. When values corresponding to the dict type are (un)marshalled, they are represented as the Perl HASH data type (see L). If, for example, a method was declared to have a single parameter with the type ["dict", "string", "string"], then when calling the method one would provide a hash reference of strings, $object->hello({forename => "John", surname => "Doe"}); =item ["struct", VALUE-TYPE-1, VALUE-TYPE-2] A structure of values, best thought of as a variation on the array type where the elements can vary. Many languages have an explicit name associated with each value, but since Perl does not have a native representation of structures, they are represented by the LIST data type. If, for exaple, a method was declared to have a single parameter with the type ["struct", "string", "string"], corresponding to the C structure struct { char *forename; char *surname; } name; then, when calling the method one would provide an array refernce with the values orded to match the structure $object->hello(["John", "Doe"]); =back =head1 MAGIC TYPES When specifying introspection data for an exported service, there are a couple of so called C types. Parameters declared as magic types are not visible to clients, but instead their values are provided automatically by the server side bindings. One use of magic types is to get an extra parameter passed with the unique name of the caller invoking the method. =over 4 =item "caller" The value passed in is the unique name of the caller of the method. Unique names are strings automatically assigned to client connections by the bus daemon, for example ':1.15' =item "serial" The value passed in is an integer within the scope of a caller, which increments on every method call. =back =head1 ANNOTATIONS When exporting methods, signals & properties, in addition to the core data typing information, a number of metadata annotations are possible. These are specified by passing a hash reference with the desired keys as the last parameter when defining the export. The following annotations are currently supported =over 4 =item no_return Indicate that this method does not return any value, and thus no reply message should be sent over the wire, likewise informing the clients not to expect / wait for a reply message =item deprecated Indicate that use of this method/signal/property is discouraged, and it may disappear altogether in a future release. Clients will typically print out a warning message when a deprecated method/signal/property is used. =item param_names An array of strings specifying names for the input parameters of the method or signal. If omitted, no names will be assigned. =item return_names An array of strings specifying names for the return parameters of the method. If omitted, no names will be assigned. =back =head1 METHODS =over 4 =cut package Net::DBus::Exporter; use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors); use Net::DBus::Binding::Introspector; use warnings; use strict; use Exporter; @ISA = qw(Exporter); @EXPORT = qw(dbus_method dbus_signal dbus_property dbus_no_strict_exports); sub import { my $class = shift; my $caller = caller; if (exists $dbus_exports{$caller}) { warn "$caller is already registered with Net::DBus::Exporter"; return; } $dbus_exports{$caller} = { strict => 1, methods => {}, signals => {}, props => {}, }; die "usage: use Net::DBus::Exporter 'interface-name';" unless @_; my $interface = shift; &_validate_interface($interface); $dbus_exports{$caller}->{interface} = $interface; $class->export_to_level(1, "", @EXPORT); } sub _dbus_introspector { my $class = shift; if (!exists $dbus_exports{$class}) { # If this class has not been exported, lets look # at the parent class & return its introspection # data instead. no strict 'refs'; if (defined (*{"${class}::ISA"})) { my @isa = @{"${class}::ISA"}; foreach my $parent (@isa) { # We don't recurse to Net::DBus::Object # since we need to give sub-classes the # choice of not supporting introspection next if $parent eq "Net::DBus::Object"; my $ins = &_dbus_introspector($parent); if ($ins) { return $ins; } } } return undef; } unless (exists $dbus_introspectors{$class}) { my $is = Net::DBus::Binding::Introspector->new(strict=>$dbus_exports{$class}->{strict}); &_dbus_introspector_add($class, $is); $dbus_introspectors{$class} = $is; } return $dbus_introspectors{$class}; } sub _dbus_introspector_add { my $class = shift; my $introspector = shift; my $exports = $dbus_exports{$class}; if ($exports) { foreach my $method (keys %{$exports->{methods}}) { my ($params, $returns, $interface, $attributes, $paramnames, $returnnames) = @{$exports->{methods}->{$method}}; $introspector->add_method($method, $params, $returns, $interface, $attributes, $paramnames, $returnnames); } foreach my $prop (keys %{$exports->{props}}) { my ($type, $access, $interface, $attributes) = @{$exports->{props}->{$prop}}; $introspector->add_property($prop, $type, $access, $interface, $attributes); } foreach my $signal (keys %{$exports->{signals}}) { my ($params, $interface, $attributes, $paramnames) = @{$exports->{signals}->{$signal}}; $introspector->add_signal($signal, $params, $interface, $attributes, $paramnames); } } if (defined (*{"${class}::ISA"})) { no strict "refs"; my @isa = @{"${class}::ISA"}; foreach my $parent (@isa) { &_dbus_introspector_add($parent, $introspector); } } } =item dbus_method($name, $params, $returns, [\%annotations]); =item dbus_method($name, $params, $returns, $interface, [\%annotations]); Exports a method called C<$name>, having parameters whose types are defined by C<$params>, and returning values whose types are defined by C<$returns>. If the C<$interface> parameter is provided, then the method is associated with that interface, otherwise the default interface for the calling package is used. The value for the C<$params> parameter should be an array reference with each element defining the data type of a parameter to the method. Likewise, the C<$returns> parameter should be an array reference with each element defining the data type of a return value. If it not possible to export a method which accepts a variable number of parameters, or returns a variable number of values. =cut sub dbus_method { my $name = shift; my $params = []; my $returns = []; my $caller = caller; my $interface = $dbus_exports{$caller}->{interface}; my %attributes; if (@_ && ref($_[0]) eq "ARRAY") { $params = shift; } if (@_ && ref($_[0]) eq "ARRAY") { $returns = shift; } if (@_ && !ref($_[0])) { $interface = shift; &_validate_interface($interface); } if (@_ && ref($_[0]) eq "HASH") { %attributes = %{$_[0]}; } if (!$interface) { die "interface not specified & no default interface defined"; } my $param_names = []; if ( $attributes{param_names} ) { $param_names = $attributes{param_names} if ref($attributes{param_names}) eq "ARRAY"; delete($attributes{param_names}); } my $return_names = []; if ( $attributes{return_names} ) { $return_names = $attributes{return_names} if ref($attributes{return_names}) eq "ARRAY"; delete($attributes{return_names}); } $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $param_names, $return_names]; } =item dbus_no_strict_exports(); If a object is using the Exporter to generate DBus introspection data, the default behaviour is to only allow invocation of methods which have been explicitly exported. To allow clients to access methods which have not been explicitly exported, call C. NB, doing this may be a security risk if you have methods considered to be "private" for internal use only. As such this method should not normally be used. It is here only to allow switching export behaviour to match earlier releases. =cut sub dbus_no_strict_exports { my $caller = caller; $dbus_exports{$caller}->{strict} = 0; } =item dbus_property($name, $type, $access, [\%attributes]); =item dbus_property($name, $type, $access, $interface, [\%attributes]); Exports a property called C<$name>, whose data type is C<$type>. If the C<$interface> parameter is provided, then the property is associated with that interface, otherwise the default interface for the calling package is used. =cut sub dbus_property { my $name = shift; my $type = "string"; my $access = "readwrite"; my $caller = caller; my $interface = $dbus_exports{$caller}->{interface}; my %attributes; if (@_ && (!ref($_[0]) || (ref($_[0]) eq "ARRAY"))) { $type = shift; } if (@_ && !ref($_[0])) { $access = shift; } if (@_ && !ref($_[0])) { $interface = shift; &_validate_interface($interface); } if ($_ && ref($_[0]) eq "HASH") { %attributes = %{$_[0]}; } if (!$interface) { die "interface not specified & no default interface defined"; } $dbus_exports{$caller}->{props}->{$name} = [$type, $access, $interface, \%attributes]; } =item dbus_signal($name, $params, [\%attributes]); =item dbus_signal($name, $params, $interface, [\%attributes]); Exports a signal called C<$name>, having parameters whose types are defined by C<$params>. If the C<$interface> parameter is provided, then the signal is associated with that interface, otherwise the default interface for the calling package is used. The value for the C<$params> parameter should be an array reference with each element defining the data type of a parameter to the signal. Signals do not have return values. It not possible to export a signal which has a variable number of parameters. =cut sub dbus_signal { my $name = shift; my $params = []; my $caller = caller; my $interface = $dbus_exports{$caller}->{interface}; my %attributes; if (@_ && ref($_[0]) eq "ARRAY") { $params = shift; } if (@_ && !ref($_[0])) { $interface = shift; &_validate_interface($interface); } if (@_ && ref($_[0]) eq "HASH") { %attributes = %{$_[0]}; } if (!$interface) { die "interface not specified & no default interface defined"; } my $param_names = []; if ( $attributes{param_names} ) { $param_names = $attributes{param_names} if ref($attributes{param_names}) eq "ARRAY"; delete($attributes{param_names}); } $dbus_exports{$caller}->{signals}->{$name} = [$params, $interface, \%attributes, $param_names]; } sub _validate_interface { my $interface = shift; die "interface name '$interface' is not valid.\n" . " * Interface names are composed of 1 or more elements separated by a\n" . " period ('.') character. All elements must contain at least one character.\n" . " * Each element must only contain the ASCII characters '[A-Z][a-z][0-9]_'\n" . " and must not begin with a digit.\n" . " * Interface names must contain at least one '.' (period) character (and\n" . " thus at least two elements).\n" . " * Interface names must not begin with a '.' (period) character.\n" unless $interface =~ /^[a-zA-Z_]\w*(\.[a-zA-Z_]\w*)+$/; } 1; =back =head1 EXAMPLES =over 4 =item No paramters, no return values A method which simply prints "Hello World" each time its called sub Hello { my $self = shift; print "Hello World\n"; } dbus_method("Hello", [], []); =item One string parameter, returning an boolean value A method which accepts a process name, issues the killall command on it, and returns a boolean value to indicate whether it was successful. sub KillAll { my $self = shift; my $processname = shift; my $ret = system("killall $processname"); return $ret == 0 ? 1 : 0; } dbus_method("KillAll", ["string"], ["bool"]); =item One list of strings parameter, returning a dictionary A method which accepts a list of files names, stats them, and returns a dictionary containing the last modification times. sub LastModified { my $self = shift; my $files = shift; my %mods; foreach my $file (@{$files}) { $mods{$file} = (stat $file)[9]; } return \%mods; } dbus_method("LastModified", ["array", "string"], ["dict", "string", "int32"]); =item Annotating methods with metdata A method which is targetted for removal, and also does not return any value sub PlayMP3 { my $self = shift; my $track = shift; system "mpg123 $track &"; } dbus_method("PlayMP3", ["string"], [], { deprecated => 1, no_return => 1 }); Or giving names to input parameters: sub PlayMP3 { my $self = shift; my $track = shift; system "mpg123 $track &"; } dbus_method("PlayMP3", ["string"], [], { param_names => ["track"] }); =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copright (C) 2004-2011, Daniel Berrange. =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/0000755000076500007650000000000011603165554016750 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/Binding/Message.pm0000644000076500007650000002452511603165524020677 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Message - Base class for messages =head1 SYNOPSIS Sending a message my $msg = new Net::DBus::Binding::Message::Signal; my $iterator = $msg->iterator; $iterator->append_byte(132); $iterator->append_int32(14241); $connection->send($msg); =head1 DESCRIPTION Provides a base class for the different kinds of message that can be sent/received. Instances of this class are never instantiated directly, rather one of the four sub-types L, L, L, L should be used. =head1 CONSTANTS The following constants are defined in this module. They are not exported into the caller's namespace & thus must be referenced with their fully qualified package names =over 4 =item TYPE_ARRAY Constant representing the signature value associated with the array data type. =item TYPE_BOOLEAN Constant representing the signature value associated with the boolean data type. =item TYPE_BYTE Constant representing the signature value associated with the byte data type. =item TYPE_DICT_ENTRY Constant representing the signature value associated with the dictionary entry data type. =item TYPE_DOUBLE Constant representing the signature value associated with the IEEE double precision floating point data type. =item TYPE_INT16 Constant representing the signature value associated with the signed 16 bit integer data type. =item TYPE_INT32 Constant representing the signature value associated with the signed 32 bit integer data type. =item TYPE_INT64 Constant representing the signature value associated with the signed 64 bit integer data type. =item TYPE_OBJECT_PATH Constant representing the signature value associated with the object path data type. =item TYPE_STRING Constant representing the signature value associated with the UTF-8 string data type. =item TYPE_SIGNATURE Constant representing the signature value associated with the signature data type. =item TYPE_STRUCT Constant representing the signature value associated with the struct data type. =item TYPE_UINT16 Constant representing the signature value associated with the unsigned 16 bit integer data type. =item TYPE_UINT32 Constant representing the signature value associated with the unsigned 32 bit integer data type. =item TYPE_UINT64 Constant representing the signature value associated with the unsigned 64 bit integer data type. =item TYPE_VARIANT Constant representing the signature value associated with the variant data type. =back =head1 METHODS =over 4 =cut package Net::DBus::Binding::Message; use 5.006; use strict; use warnings; use Net::DBus::Binding::Iterator; use Net::DBus::Binding::Message::Signal; use Net::DBus::Binding::Message::MethodCall; use Net::DBus::Binding::Message::MethodReturn; use Net::DBus::Binding::Message::Error; =item my $msg = Net::DBus::Binding::Message->new(message => $rawmessage); Creates a new message object, initializing it with the underlying C message object given by the C object. This constructor is intended for internal use only, instead refer to one of the four sub-types for this class for specific message types =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{message} = exists $params{message} ? $params{message} : (Net::DBus::Binding::Message::_create(exists $params{type} ? $params{type} : die "type parameter is required")); bless $self, $class; if ($class eq "Net::DBus::Binding::Message") { $self->_specialize; } return $self; } sub _specialize { my $self = shift; my $type = $self->get_type; if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL) { bless $self, "Net::DBus::Binding::Message::MethodCall"; } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { bless $self, "Net::DBus::Binding::Message::MethodReturn"; } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { bless $self, "Net::DBus::Binding::Message::Error"; } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL) { bless $self, "Net::DBus::Binding::Message::Signal"; } else { warn "Unknown message type $type\n"; } } =item my $type = $msg->get_type Retrieves the type code for this message. The returned value corresponds to one of the four C constants. =cut sub get_type { my $self = shift; return $self->{message}->dbus_message_get_type; } =item my $interface = $msg->get_interface Retrieves the name of the interface targetted by this message, possibly an empty string if there is no applicable interface for this message. =cut sub get_interface { my $self = shift; return $self->{message}->dbus_message_get_interface; } =item my $path = $msg->get_path Retrieves the object path associated with the message, possibly an empty string if there is no applicable object for this message. =cut sub get_path { my $self = shift; return $self->{message}->dbus_message_get_path; } =item my $name = $msg->get_destination Retrieves the uniqe or well-known bus name for client intended to be the recipient of the message. Possibly returns an empty string if the message is being broadcast to all clients. =cut sub get_destination { my $self = shift; return $self->{message}->dbus_message_get_destination; } =item my $name = $msg->get_sender Retireves the unique name of the client sending the message =cut sub get_sender { my $self = shift; return $self->{message}->dbus_message_get_sender; } =item my $serial = $msg->get_serial Retrieves the unique serial number of this message. The number is guarenteed unique for as long as the connection over which the message was sent remains open. May return zero, if the message is yet to be sent. =cut sub get_serial { my $self = shift; return $self->{message}->dbus_message_get_serial; } =item my $name = $msg->get_member For method calls, retrieves the name of the method to be invoked, while for signals, retrieves the name of the signal. =cut sub get_member { my $self = shift; return $self->{message}->dbus_message_get_member; } =item my $sig = $msg->get_signature Retrieves a string representing the type signature of the values packed into the body of the message. =cut sub get_signature { my $self = shift; return $self->{message}->dbus_message_get_signature; } =item $msg->set_sender($name) Set the name of the client sending the message. The name must be the unique name of the client. =cut sub set_sender { my $self = shift; $self->{message}->dbus_message_set_sender(@_); } =item $msg->set_destination($name) Set the name of the intended recipient of the message. This is typically used for signals to switch them from broadcast to unicast. =cut sub set_destination { my $self = shift; $self->{message}->dbus_message_set_destination(@_); } =item my $iterator = $msg->iterator; Retrieves an iterator which can be used for reading or writing fields of the message. The returned object is an instance of the C class. =cut sub iterator { my $self = shift; my $append = @_ ? shift : 0; if ($append) { return Net::DBus::Binding::Message::_iterator_append($self->{message}); } else { return Net::DBus::Binding::Message::_iterator($self->{message}); } } =item $boolean = $msg->get_no_reply() Gets the flag indicating whether the message is expecting a reply to be sent. =cut sub get_no_reply { my $self = shift; return $self->{message}->dbus_message_get_no_reply; } =item $msg->set_no_reply($boolean) Toggles the flag indicating whether the message is expecting a reply to be sent. All method call messages expect a reply by default. By toggling this flag the communication latency is reduced by removing the need for the client to wait =cut sub set_no_reply { my $self = shift; my $flag = shift; $self->{message}->dbus_message_set_no_reply($flag); } =item my @values = $msg->get_args_list De-marshall all the values in the body of the message, using the message signature to identify data types. The values are returned as a list. =cut sub get_args_list { my $self = shift; my @ret; my $iter = $self->iterator; if ($iter->get_arg_type() != &Net::DBus::Binding::Message::TYPE_INVALID) { do { push @ret, $iter->get(); } while ($iter->next); } return @ret; } =item $msg->append_args_list(@values) Append a set of values to the body of the message. Values will be encoded as either a string, list or dictionary as appropriate to their Perl data type. For more specific data typing needs, the L object should be used instead. =cut sub append_args_list { my $self = shift; my @args = @_; my $iter = $self->iterator(1); foreach my $arg (@args) { $iter->append($arg); } } # To keep autoloader quiet sub DESTROY { } sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; die "&Net::DBus::Binding::Message::constant not defined" if $constname eq '_constant'; if (!exists $Net::DBus::Binding::Message::_constants{$constname}) { die "no such constant \$Net::DBus::Binding::Message::$constname"; } { no strict 'refs'; *$AUTOLOAD = sub { $Net::DBus::Binding::Message::_constants{$constname} }; } goto &$AUTOLOAD; } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L, L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Watch.pm0000644000076500007650000000256511603165524020361 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Watch - binding to the dbus watch API =cut package Net::DBus::Binding::Watch; use 5.006; use strict; use warnings; use Net::DBus; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; die "&Net::DBus::Binding::Watch::constant not defined" if $constname eq '_constant'; if (!exists $Net::DBus::Binding::Watch::_constants{$constname}) { die "no such constant \$Net::DBus::Binding::Watch::$constname"; } { no strict 'refs'; *$AUTOLOAD = sub { $Net::DBus::Binding::Watch::_constants{$constname} }; } goto &$AUTOLOAD; } 1; =pod =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Message/0000755000076500007650000000000011603165554020334 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/Binding/Message/Signal.pm0000644000076500007650000000472711603165524022116 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Message::Signal - a message encoding a signal =head1 SYNOPSIS use Net::DBus::Binding::Message::Signal; my $signal = Net::DBus::Binding::Message::Signal->new( object_path => "/org/example/myobject", interface => "org.example.myobject", signal_name => "foo_changed"); $connection->send($signal); =head1 DESCRIPTION This module is part of the low-level DBus binding APIs, and should not be used by application code. No guarentees are made about APIs under the C namespace being stable across releases. This module provides a convenience constructor for creating a message representing a signal. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Message::Signal; use 5.006; use strict; use warnings; use Net::DBus; use base qw(Net::DBus::Binding::Message); =item my $signal = Net::DBus::Binding::Message::Signal->new( object_path => $path, interface => $interface, signal_name => $name); Creates a new message, representing a signal [to be] emitted by the object located under the path given by the C parameter. The name of the signal is given by the C parameter, and is scoped to the interface given by the C parameter. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $msg = exists $params{message} ? $params{message} : Net::DBus::Binding::Message::Signal::_create ( ($params{object_path} ? $params{object_path} : die "object_path parameter is required"), ($params{interface} ? $params{interface} : die "interface parameter is required"), ($params{signal_name} ? $params{signal_name} : die "signal_name parameter is required")); my $self = $class->SUPER::new(message => $msg); bless $self, $class; return $self; } 1; __END__ =back =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2004-2009 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Message/MethodCall.pm0000644000076500007650000000453511603165524022712 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Message::MethodCall - a message encoding a method call =head1 DESCRIPTION This module is part of the low-level DBus binding APIs, and should not be used by application code. No guarentees are made about APIs under the C namespace being stable across releases. This module provides a convenience constructor for creating a message representing a method call. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Message::MethodCall; use 5.006; use strict; use warnings; use Net::DBus; use base qw(Exporter Net::DBus::Binding::Message); =item my $call = Net::DBus::Binding::Message::MethodCall->new( service_name => $service, object_path => $object, interface => $interface, method_name => $name); Create a message representing a call on the object located at the path C within the client owning the well-known name given by C. The method to be invoked has the name C within the interface specified by the C parameter. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $msg = exists $params{message} ? $params{message} : Net::DBus::Binding::Message::MethodCall::_create ( ($params{service_name} ? $params{service_name} : die "service_name parameter is required"), ($params{object_path} ? $params{object_path} : die "object_path parameter is required"), ($params{interface} ? $params{interface} : die "interface parameter is required"), ($params{method_name} ? $params{method_name} : die "method_name parameter is required")); my $self = $class->SUPER::new(message => $msg); bless $self, $class; return $self; } 1; __END__ =back =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2004-2009 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Message/Error.pm0000644000076500007650000000545511603165524021771 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Message::Error - a message encoding a method call error =head1 SYNOPSIS use Net::DBus::Binding::Message::Error; my $error = Net::DBus::Binding::Message::Error->new( replyto => $method_call, name => "org.example.myobject.FooException", description => "Unable to do Foo when updating bar"); $connection->send($error); =head1 DESCRIPTION This module is part of the low-level DBus binding APIs, and should not be used by application code. No guarentees are made about APIs under the C namespace being stable across releases. This module provides a convenience constructor for creating a message representing an error condition. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Message::Error; use 5.006; use strict; use warnings; use Net::DBus; use base qw(Net::DBus::Binding::Message); =item my $error = Net::DBus::Binding::Message::Error->new( replyto => $method_call, name => $name, description => $description); Creates a new message, representing an error which occurred during the handling of the method call object passed in as the C parameter. The C parameter is the formal name of the error condition, while the C is a short piece of text giving more specific information on the error. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $replyto = exists $params{replyto} ? $params{replyto} : die "replyto parameter is required"; my $msg = exists $params{message} ? $params{message} : Net::DBus::Binding::Message::Error::_create ( $replyto->{message}, ($params{name} ? $params{name} : die "name parameter is required"), ($params{description} ? $params{description} : die "description parameter is required")); my $self = $class->SUPER::new(message => $msg); bless $self, $class; return $self; } =item my $name = $error->get_error_name Returns the formal name of the error, as previously passed in via the C parameter in the constructor. =cut sub get_error_name { my $self = shift; return $self->{message}->dbus_message_get_error_name; } 1; __END__ =back =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2004-2009 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Message/MethodReturn.pm0000644000076500007650000000355111603165524023313 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Message::MethodReturn - a message encoding a method return =head1 DESCRIPTION This module is part of the low-level DBus binding APIs, and should not be used by application code. No guarentees are made about APIs under the C namespace being stable across releases. This module provides a convenience constructor for creating a message representing an method return. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Message::MethodReturn; use 5.006; use strict; use warnings; use Net::DBus; use base qw(Exporter Net::DBus::Binding::Message); =item my $return = Net::DBus::Binding::Message::MethodReturn->new( call => $method_call); Create a message representing a reply to the method call passed in the C parameter. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $call = exists $params{call} ? $params{call} : die "call parameter is required"; my $msg = exists $params{message} ? $params{message} : Net::DBus::Binding::Message::MethodReturn::_create($call->{message}); my $self = $class->SUPER::new(message => $msg); bless $self, $class; return $self; } 1; __END__ =back =head1 AUTHOR Daniel P. Berrange. =head1 COPYRIGHT Copyright (C) 2005-2009 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Introspector.pm0000644000076500007650000010353611603165524022006 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Introspector - Handler for object introspection data =head1 SYNOPSIS # Create an object populating with info from an # XML doc containing introspection data. my $ins = Net::DBus::Binding::Introspector->new(xml => $data); # Create an object, defining introspection data # programmatically my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); $ins->add_method("DoSomething", ["string"], [], "org.example.MyObject"); $ins->add_method("TestSomething", ["int32"], [], "org.example.MyObject"); =head1 DESCRIPTION This class is responsible for managing introspection data, and answering questions about it. This is not intended for use by application developers, whom should instead consult the higher level API in L. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Introspector; use 5.006; use strict; use warnings; use XML::Twig; use Net::DBus::Binding::Message; our $debug = 0; BEGIN { if ($ENV{NET_DBUS_DEBUG} && $ENV{NET_DBUS_DEBUG} eq "introspect") { $debug = 1; } } our %simple_type_map = ( "byte" => &Net::DBus::Binding::Message::TYPE_BYTE, "bool" => &Net::DBus::Binding::Message::TYPE_BOOLEAN, "double" => &Net::DBus::Binding::Message::TYPE_DOUBLE, "string" => &Net::DBus::Binding::Message::TYPE_STRING, "int16" => &Net::DBus::Binding::Message::TYPE_INT16, "uint16" => &Net::DBus::Binding::Message::TYPE_UINT16, "int32" => &Net::DBus::Binding::Message::TYPE_INT32, "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32, "int64" => &Net::DBus::Binding::Message::TYPE_INT64, "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64, "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH, "signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE, ); our %simple_type_rev_map = ( &Net::DBus::Binding::Message::TYPE_BYTE => "byte", &Net::DBus::Binding::Message::TYPE_BOOLEAN => "bool", &Net::DBus::Binding::Message::TYPE_DOUBLE => "double", &Net::DBus::Binding::Message::TYPE_STRING => "string", &Net::DBus::Binding::Message::TYPE_INT16 => "int16", &Net::DBus::Binding::Message::TYPE_UINT16 => "uint16", &Net::DBus::Binding::Message::TYPE_INT32 => "int32", &Net::DBus::Binding::Message::TYPE_UINT32 => "uint32", &Net::DBus::Binding::Message::TYPE_INT64 => "int64", &Net::DBus::Binding::Message::TYPE_UINT64 => "uint64", &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath", &Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature", ); our %magic_type_map = ( "caller" => sub { my $msg = shift; return $msg->get_sender; }, "serial" => sub { my $msg = shift; return $msg->get_serial; }, ); our %compound_type_map = ( "array" => &Net::DBus::Binding::Message::TYPE_ARRAY, "struct" => &Net::DBus::Binding::Message::TYPE_STRUCT, "dict" => &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT, ); =item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path, xml => $xml); Creates a new introspection data manager for the object registered at the path specified for the C parameter. The optional C parameter can be used to pre-load the manager with introspection metadata from an XML document. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; my %params = @_; $self->{interfaces} = {}; bless $self, $class; if (defined $params{xml}) { $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; $self->_parse($params{xml}); } elsif (defined $params{node}) { $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; $self->_parse_node($params{node}); } else { $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; $self->{interfaces} = $params{interfaces} if exists $params{interfaces}; $self->{children} = exists $params{children} ? $params{children} : []; } $self->{strict} = exists $params{strict} ? $params{strict} : 0; # Some versions of dbus failed to include signals in introspection data # so this code adds them, letting us keep compatability with old versions if (defined $self->{object_path} && $self->{object_path} eq "/org/freedesktop/DBus") { if (!$self->has_signal("NameOwnerChanged")) { $self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus"); } if (!$self->has_signal("NameLost")) { $self->add_signal("NameLost", ["string"], "org.freedesktop.DBus"); } if (!$self->has_signal("NameAcquired")) { $self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus"); } } return $self; } =item $ins->add_interface($name) Register the object as providing an interface with the name C<$name> =cut sub add_interface { my $self = shift; my $name = shift; $self->{interfaces}->{$name} = { methods => {}, signals => {}, props => {}, } unless exists $self->{interfaces}->{$name}; } =item my $bool = $ins->has_interface($name) Return a true value if the object is registered as providing an interface with the name C<$name>; returns false otherwise. =cut sub has_interface { my $self = shift; my $name = shift; return exists $self->{interfaces}->{$name} ? 1 : 0; } =item my @interfaces = $ins->has_method($name, [$interface]) Return a list of all interfaces provided by the object, which contain a method called C<$name>. This may be an empty list. The optional C<$interface> parameter can restrict the check to just that one interface. =cut sub has_method { my $self = shift; my $name = shift; if (@_) { my $interface = shift; return () unless exists $self->{interfaces}->{$interface}; return () unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; return ($interface); } else { my @interfaces; foreach my $interface (keys %{$self->{interfaces}}) { if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { push @interfaces, $interface; } } return @interfaces; } } =item my $boolean = $ins->is_method_allowed($name[, $interface]) Checks according to whether the remote caller is allowed to invoke the method C<$name> on the object associated with this introspector. If this object has 'strict exports' enabled, then only explicitly exported methods will be allowed. The optional C<$interface> parameter can restrict the check to just that one interface. Returns a non-zero value if the method should be allowed. =cut sub is_method_allowed { my $self = shift; my $name = shift; if ($self->{strict}) { return $self->has_method($name, @_) ? 1 : 0; } else { return 1; } } =item my @interfaces = $ins->has_signal($name) Return a list of all interfaces provided by the object, which contain a signal called C<$name>. This may be an empty list. =cut sub has_signal { my $self = shift; my $name = shift; my @interfaces; foreach my $interface (keys %{$self->{interfaces}}) { if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) { push @interfaces, $interface; } } return @interfaces; } =item my @interfaces = $ins->has_property($name) Return a list of all interfaces provided by the object, which contain a property called C<$name>. This may be an empty list. The optional C<$interface> parameter can restrict the check to just that one interface. =cut sub has_property { my $self = shift; my $name = shift; if (@_) { my $interface = shift; return () unless exists $self->{interfaces}->{$interface}; return () unless exists $self->{interfaces}->{$interface}->{props}->{$name}; return ($interface); } else { my @interfaces; foreach my $interface (keys %{$self->{interfaces}}) { if (exists $self->{interfaces}->{$interface}->{props}->{$name}) { push @interfaces, $interface; } } return @interfaces; } } =item $ins->add_method($name, $params, $returns, $interface, $attributes, $paramnames, $returnnames); Register the object as providing a method called C<$name> accepting parameters whose types are declared by C<$params> and returning values whose type are declared by C<$returns>. The method will be scoped to the inteface named by C<$interface>. The C<$attributes> parameter is a hash reference for annotating the method. The C<$paramnames> and C<$returnames> parameters are a list of argument and return value names. =cut sub add_method { my $self = shift; my $name = shift; my $params = shift; my $returns = shift; my $interface = shift; my $attributes = shift; my $paramnames = shift; my $returnnames = shift; $self->add_interface($interface); $self->{interfaces}->{$interface}->{methods}->{$name} = { params => $params, returns => $returns, paramnames => $paramnames, returnnames => $returnnames, deprecated => $attributes->{deprecated} ? 1 : 0, no_reply => $attributes->{no_return} ? 1 : 0, }; } =item $ins->add_signal($name, $params, $interface, $attributes); Register the object as providing a signal called C<$name> with parameters whose types are declared by C<$params>. The signal will be scoped to the inteface named by C<$interface>. The C<$attributes> parameter is a hash reference for annotating the signal. =cut sub add_signal { my $self = shift; my $name = shift; my $params = shift; my $interface = shift; my $attributes = shift; my $paramnames = shift; $self->add_interface($interface); $self->{interfaces}->{$interface}->{signals}->{$name} = { params => $params, paramnames => $paramnames, deprecated => $attributes->{deprecated} ? 1 : 0, }; } =item $ins->add_property($name, $type, $access, $interface, $attributes); Register the object as providing a property called C<$name> with a type of C<$type>. The C<$access> parameter can be one of C, C, or C. The property will be scoped to the inteface named by C<$interface>. The C<$attributes> parameter is a hash reference for annotating the signal. =cut sub add_property { my $self = shift; my $name = shift; my $type = shift; my $access = shift; my $interface = shift; my $attributes = shift; $self->add_interface($interface); $self->{interfaces}->{$interface}->{props}->{$name} = { type => $type, access => $access, deprecated => $attributes->{deprecated} ? 1 : 0, }; } =item my $boolean = $ins->is_method_deprecated($name, $interface) Returns a true value if the method called C<$name> in the interface C<$interface> is marked as deprecated =cut sub is_method_deprecated { my $self = shift; my $name = shift; my $interface = shift; die "no interface $interface" unless exists $self->{interfaces}->{$interface}; die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{deprecated}; return 0; } =item my $boolean = $ins->is_signal_deprecated($name, $interface) Returns a true value if the signal called C<$name> in the interface C<$interface> is marked as deprecated =cut sub is_signal_deprecated { my $self = shift; my $name = shift; my $interface = shift; die "no interface $interface" unless exists $self->{interfaces}->{$interface}; die "no signal $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{signals}->{$name}; return 1 if $self->{interfaces}->{$interface}->{signals}->{$name}->{deprecated}; return 0; } =item my $boolean = $ins->is_property_deprecated($name, $interface) Returns a true value if the property called C<$name> in the interface C<$interface> is marked as deprecated =cut sub is_property_deprecated { my $self = shift; my $name = shift; my $interface = shift; die "no interface $interface" unless exists $self->{interfaces}->{$interface}; die "no property $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{props}->{$name}; return 1 if $self->{interfaces}->{$interface}->{props}->{$name}->{deprecated}; return 0; } =item my $boolean = $ins->does_method_reply($name, $interface) Returns a true value if the method called C<$name> in the interface C<$interface> will generate a reply. Returns a false value otherwise. =cut sub does_method_reply { my $self = shift; my $name = shift; my $interface = shift; die "no interface $interface" unless exists $self->{interfaces}->{$interface}; die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; return 0 if $self->{interfaces}->{$interface}->{methods}->{$name}->{no_reply}; return 1; } =item my @names = $ins->list_interfaces Returns a list of all interfaces registered as being provided by the object. =cut sub list_interfaces { my $self = shift; return keys %{$self->{interfaces}}; } =item my @names = $ins->list_methods($interface) Returns a list of all methods registered as being provided by the object, within the interface C<$interface>. =cut sub list_methods { my $self = shift; my $interface = shift; return keys %{$self->{interfaces}->{$interface}->{methods}}; } =item my @names = $ins->list_signals($interface) Returns a list of all signals registered as being provided by the object, within the interface C<$interface>. =cut sub list_signals { my $self = shift; my $interface = shift; return keys %{$self->{interfaces}->{$interface}->{signals}}; } =item my @names = $ins->list_properties($interface) Returns a list of all properties registered as being provided by the object, within the interface C<$interface>. =cut sub list_properties { my $self = shift; my $interface = shift; return keys %{$self->{interfaces}->{$interface}->{props}}; } =item my @paths = $self->list_children; Returns a list of object paths representing all the children of this node. =cut sub list_children { my $self = shift; return @{$self->{children}}; } =item my $path = $ins->get_object_path Returns the path of the object associated with this introspection data =cut sub get_object_path { my $self = shift; return $self->{object_path}; } =item my @types = $ins->get_method_params($interface, $name) Returns a list of declared data types for parameters of the method called C<$name> within the interface C<$interface>. =cut sub get_method_params { my $self = shift; my $interface = shift; my $method = shift; return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{params}}; } =item my @types = $ins->get_method_param_names($interface, $name) Returns a list of declared names for parameters of the method called C<$name> within the interface C<$interface>. =cut sub get_method_param_names { my $self = shift; my $interface = shift; my $method = shift; return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{paramnames}}; } =item my @types = $ins->get_method_returns($interface, $name) Returns a list of declared data types for return values of the method called C<$name> within the interface C<$interface>. =cut sub get_method_returns { my $self = shift; my $interface = shift; my $method = shift; return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}}; } =item my @types = $ins->get_method_return_names($interface, $name) Returns a list of declared names for return values of the method called C<$name> within the interface C<$interface>. =cut sub get_method_return_names { my $self = shift; my $interface = shift; my $method = shift; return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returnnames}}; } =item my @types = $ins->get_signal_params($interface, $name) Returns a list of declared data types for values associated with the signal called C<$name> within the interface C<$interface>. =cut sub get_signal_params { my $self = shift; my $interface = shift; my $signal = shift; return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{params}}; } =item my @types = $ins->get_signal_param_names($interface, $name) Returns a list of declared names for values associated with the signal called C<$name> within the interface C<$interface>. =cut sub get_signal_param_names { my $self = shift; my $interface = shift; my $signal = shift; return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{paramnames}}; } =item my $type = $ins->get_property_type($interface, $name) Returns the declared data type for property called C<$name> within the interface C<$interface>. =cut sub get_property_type { my $self = shift; my $interface = shift; my $prop = shift; return $self->{interfaces}->{$interface}->{props}->{$prop}->{type}; } =item my $bool = $ins->is_property_readable($interface, $name); Returns a true value if the property called C<$name> within the interface C<$interface> can have its value read. =cut sub is_property_readable { my $self = shift; my $interface = shift; my $prop = shift; my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access}; return $access eq "readwrite" || $access eq "read" ? 1 : 0; } =item my $bool = $ins->is_property_writable($interface, $name); Returns a true value if the property called C<$name> within the interface C<$interface> can have its value written to. =cut sub is_property_writable { my $self = shift; my $interface = shift; my $prop = shift; my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access}; return $access eq "readwrite" || $access eq "write" ? 1 : 0; } sub _parse { my $self = shift; my $xml = shift; my $twig = XML::Twig->new(); $twig->parse($xml); $self->_parse_node($twig->root); } sub _parse_node { my $self = shift; my $node = shift; $self->{object_path} = $node->att("name") if defined $node->att("name"); die "no object path provided" unless defined $self->{object_path}; $self->{children} = []; foreach my $child ($node->children("interface")) { $self->_parse_interface($child); } foreach my $child ($node->children("node")) { if (!$child->has_children()) { push @{$self->{children}}, $child->att("name"); } else { push @{$self->{children}}, $self->new(node => $child); } } } sub _parse_interface { my $self = shift; my $node = shift; my $name = $node->att("name"); $self->{interfaces}->{$name} = { methods => {}, signals => {}, props => {}, }; foreach my $child ($node->children("method")) { $self->_parse_method($child, $name); } foreach my $child ($node->children("signal")) { $self->_parse_signal($child, $name); } foreach my $child ($node->children("property")) { $self->_parse_property($child, $name); } } sub _parse_method { my $self = shift; my $node = shift; my $interface = shift; my $name = $node->att("name"); my @params; my @returns; my @paramnames; my @returnnames; my $deprecated = 0; my $no_reply = 0; foreach my $child ($node->children("arg")) { my $type = $child->att("type"); my $direction = $child->att("direction"); my $name = $child->att("name"); my @sig = split //, $type; my @type = $self->_parse_type(\@sig); if (!defined $direction || $direction eq "in") { push @params, @type; push @paramnames, $name; } elsif ($direction eq "out") { push @returns, @type; push @returnnames, $name; } } foreach my $child ($node->children("annotation")) { my $name = $child->att("name"); my $value = $child->att("value"); if ($name eq "org.freedesktop.DBus.Deprecated") { $deprecated = 1 if lc($value) eq "true"; } elsif ($name eq "org.freedesktop.DBus.Method.NoReply") { $no_reply = 1 if lc($value) eq "true"; } } $self->{interfaces}->{$interface}->{methods}->{$name} = { params => \@params, returns => \@returns, no_reply => $no_reply, deprecated => $deprecated, paramnames => \@paramnames, returnnames => \@returnnames, } } sub _parse_type { my $self = shift; my $sig = shift; my $root = []; my $current = $root; my @cont; while (my $type = shift @{$sig}) { if (exists $simple_type_rev_map{ord($type)}) { push @{$current}, $simple_type_rev_map{ord($type)}; if ($current->[0] eq "array") { $current = pop @cont; } } else { if ($type eq "(") { my $new = ["struct"]; push @{$current}, $new; push @cont, $current; $current = $new; } elsif ($type eq "a") { my $new = ["array"]; push @cont, $current; push @{$current}, $new; $current = $new; } elsif ($type eq "{") { if ($current->[0] ne "array") { die "dict must only occur within an array"; } $current->[0] = "dict"; } elsif ($type eq ")") { die "unexpected end of struct" unless $current->[0] eq "struct"; $current = pop @cont; if ($current->[0] eq "array") { $current = pop @cont; } } elsif ($type eq "}") { die "unexpected end of dict" unless $current->[0] eq "dict"; $current = pop @cont; if ($current->[0] eq "array") { $current = pop @cont; } } elsif ($type eq "v") { push @{$current}, ["variant"]; if ($current->[0] eq "array") { $current = pop @cont; } } else { die "unknown type sig '$type'"; } } } return @{$root}; } sub _parse_signal { my $self = shift; my $node = shift; my $interface = shift; my $name = $node->att("name"); my @params; my @paramnames; my $deprecated = 0; foreach my $child ($node->children("arg")) { my $type = $child->att("type"); my $name = $child->att("name"); my @sig = split //, $type; my @type = $self->_parse_type(\@sig); push @params, @type; push @paramnames, $name; } foreach my $child ($node->children("annotation")) { my $name = $child->att("name"); my $value = $child->att("value"); if ($name eq "org.freedesktop.DBus.Deprecated") { $deprecated = 1 if lc($value) eq "true"; } } $self->{interfaces}->{$interface}->{signals}->{$name} = { params => \@params, paramnames => \@paramnames, deprecated => $deprecated, }; } sub _parse_property { my $self = shift; my $node = shift; my $interface = shift; my $name = $node->att("name"); my $access = $node->att("access"); my $deprecated = 0; foreach my $child ($node->children("annotation")) { my $name = $child->att("name"); my $value = $child->att("value"); if ($name eq "org.freedesktop.DBus.Deprecated") { $deprecated = 1 if lc($value) eq "true"; } } my @sig = split //, $node->att("type"); $self->{interfaces}->{$interface}->{props}->{$name} = { type => $self->_parse_type(\@sig), access => $access, deprecated => $deprecated, }; } =item my $xml = $ins->format([$obj]) Return a string containing an XML document representing the state of the introspection data. The optional C<$obj> parameter can be an instance of L to include object specific information in the XML (eg child nodes). =cut sub format { my $self = shift; my $obj = shift; my $xml = '' . "\n"; return $xml . $self->to_xml("", $obj); } =item my $xml_fragment = $ins->to_xml Returns a string containing an XML fragment representing the state of the introspection data. This is basically the same as the C method, but without the leading doctype declaration. =cut sub to_xml { my $self = shift; my $indent = shift; my $obj = shift; my $xml = ''; my $path = $obj ? $obj->get_object_path : $self->{object_path}; unless (defined $path) { die "no object_path for introspector, and no object supplied"; } $xml .= $indent . '' . "\n"; foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) { my $interface = $self->{interfaces}->{$name}; $xml .= $indent . ' ' . "\n"; foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) { my $method = $interface->{methods}->{$mname}; $xml .= $indent . ' ' . "\n"; my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{paramnames}} ); my @returnnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{returnnames}} ); foreach my $type (@{$method->{params}}) { next if ! ref($type) && exists $magic_type_map{$type}; $xml .= $indent . ' ' . "\n"; } foreach my $type (@{$method->{returns}}) { next if ! ref($type) && exists $magic_type_map{$type}; $xml .= $indent . ' ' . "\n"; } if ($method->{deprecated}) { $xml .= $indent . ' ' . "\n"; } if ($method->{no_reply}) { $xml .= $indent . ' ' . "\n"; } $xml .= $indent . ' ' . "\n"; } foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) { my $signal = $interface->{signals}->{$sname}; $xml .= $indent . ' ' . "\n"; my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} ); foreach my $type (@{$signal->{params}}) { next if ! ref($type) && exists $magic_type_map{$type}; $xml .= $indent . ' ' . "\n"; } if ($signal->{deprecated}) { $xml .= $indent . ' ' . "\n"; } $xml .= $indent . ' ' . "\n"; } foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) { my $prop = $interface->{props}->{$pname}; my $type = $interface->{props}->{$pname}->{type}; my $access = $interface->{props}->{$pname}->{access}; if ($prop->{deprecated}) { $xml .= $indent . ' ' . "\n"; $xml .= $indent . ' ' . "\n"; $xml .= $indent . ' ' . "\n"; } else { $xml .= $indent . ' ' . "\n"; } } $xml .= $indent . ' ' . "\n"; } # # Interfaces don't have children, objects do # if ($obj) { foreach ( $obj->_get_sub_nodes ) { $xml .= $indent . ' ' . "\n"; } } else { foreach my $child (@{$self->{children}}) { if (ref($child) eq __PACKAGE__) { $xml .= $child->to_xml($indent . " "); } else { $xml .= $indent . ' ' . "\n"; } } } $xml .= $indent . "\n"; } =item $type = $ins->to_xml_type($type) Takes a text-based representation of a data type and returns the compact representation used in XML introspection data. =cut sub to_xml_type { my $self = shift; my $type = shift; my $sig = ''; if (ref($type) eq "ARRAY") { if ($type->[0] eq "array") { if ($#{$type} != 1) { die "array spec must contain only 1 type"; } $sig .= chr($compound_type_map{$type->[0]}); $sig .= $self->to_xml_type($type->[1]); } elsif ($type->[0] eq "struct") { $sig .= "("; for (my $i = 1 ; $i <= $#{$type} ; $i++) { $sig .= $self->to_xml_type($type->[$i]); } $sig .= ")"; } elsif ($type->[0] eq "dict") { if ($#{$type} != 2) { die "dict spec must contain only 2 types"; } $sig .= chr($compound_type_map{"array"}); $sig .= "{"; $sig .= $self->to_xml_type($type->[1]); $sig .= $self->to_xml_type($type->[2]); $sig .= "}"; } elsif ($type->[0] eq "variant") { if ($#{$type} != 0) { die "dict spec must contain no sub-types"; } $sig .= chr($compound_type_map{"variant"}); } else { die "unknown/unsupported compound type " . $type->[0] . " expecting 'array', 'struct', or 'dict'"; } } else { die "unknown/unsupported scalar type '$type'" unless exists $simple_type_map{$type}; $sig .= chr($simple_type_map{$type}); } return $sig; } =item $ins->encode($message, $type, $name, $direction, @args) Append a set of values <@args> to a message object C<$message>. The C<$type> parameter is either C or C and C<$direction> is either C or C. The introspection data will be queried to obtain the declared data types & the argument marshalling accordingly. =cut sub encode { my $self = shift; my $message = shift; my $type = shift; my $name = shift; my $direction = shift; my @args = @_; my $interface = $message->get_interface; my @types; if ($interface) { if (exists $self->{interfaces}->{$interface}) { if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) { @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; } else { warn "missing introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n" if $debug; } } else { warn "missing interface '$interface' in introspection data for object '" . $self->get_object_path . "' encoding $type '$name'\n" if $debug; } } else { foreach my $in (keys %{$self->{interfaces}}) { if (exists $self->{interfaces}->{$in}->{$type}->{$name}) { $interface = $in; } } if ($interface) { @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; } else { warn "no interface in introspection data for object " . $self->get_object_path . " encoding $type '$name'\n" if $debug; } } # If you don't explicitly 'return ()' from methods, Perl # will always return a single element representing the # return value of the last command executed in the method. # To avoid this causing a PITA for methods exported with # no return values, we throw away returns instead of dieing if ($direction eq "returns" && $#types == -1 && $#args != -1) { @args = (); } # No introspection data available, then just fallback # to a plain (guess types) append unless (@types) { $message->append_args_list(@args); return; } die "expected " . int(@types) . " $direction, but got " . int(@args) unless $#types == $#args; my $iter = $message->iterator(1); foreach my $t ($self->_convert(@types)) { $iter->append(shift @args, $t); } } sub _convert { my $self = shift; my @in = @_; my @out; foreach my $in (@in) { if (ref($in) eq "ARRAY") { my @subtype = @{$in}; shift @subtype; my @subout = $self->_convert(@subtype); die "unknown compound type " . $in->[0] unless exists $compound_type_map{lc $in->[0]}; push @out, [$compound_type_map{lc $in->[0]}, \@subout]; } elsif (exists $magic_type_map{lc $in}) { push @out, $magic_type_map{lc $in}; } else { die "unknown simple type " . $in unless exists $simple_type_map{lc $in}; push @out, $simple_type_map{lc $in}; } } return @out; } =item my @args = $ins->decode($message, $type, $name, $direction) Unmarshalls the contents of a message object C<$message>. The C<$type> parameter is either C or C and C<$direction> is either C or C. The introspection data will be queried to obtain the declared data types & the arguments unmarshalled accordingly. =cut sub decode { my $self = shift; my $message = shift; my $type = shift; my $name = shift; my $direction = shift; my $interface = $message->get_interface; my @types; if ($interface) { if (exists $self->{interfaces}->{$interface}) { if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) { @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; } else { warn "missing introspection data when decoding $type '$name' in object " . $self->get_object_path . "\n" if $debug; } } else { warn "missing interface '$interface' in introspection data for object '" . $self->get_object_path . "' when decoding $type '$name'\n" if $debug; } } else { foreach my $in (keys %{$self->{interfaces}}) { if (exists $self->{interfaces}->{$in}->{$type}->{$name}) { $interface = $in; } } if (!$interface) { warn "no interface in introspection data for object " . $self->get_object_path . " decoding $type '$name'\n" if $debug; } else { @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; } } # If there are no types defined, just return the # actual data from the message, assuming the introspection # data was partial. return $message->get_args_list unless @types; my $iter = $message->iterator; my $hasnext = 1; my @rawtypes = $self->_convert(@types); my @ret; while (@types) { my $type = shift @types; my $rawtype = shift @rawtypes; if (exists $magic_type_map{$type}) { push @ret, &$rawtype($message); } elsif ($hasnext) { push @ret, $iter->get($rawtype); $hasnext = $iter->next; } } return @ret; } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Connection.pm0000644000076500007650000004023711603165524021410 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Connection - A connection between client and server =head1 SYNOPSIS Creating a connection to a server and sending a message use Net::DBus::Binding::Connection; my $con = Net::DBus::Binding::Connection->new(address => "unix:path=/path/to/socket"); $con->send($message); Registering message handlers sub handle_something { my $con = shift; my $msg = shift; ... do something with the message... } $con->register_message_handler( "/some/object/path", \&handle_something); Hooking up to an event loop: my $reactor = Net::DBus::Binding::Reactor->new(); $reactor->manage($con); $reactor->run(); =head1 DESCRIPTION An outgoing connection to a server, or an incoming connection from a client. The methods defined on this module have a close correspondance to the dbus_connection_XXX methods in the C API, so for further details on their behaviour, the C API documentation may be of use. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Connection; use 5.006; use strict; use warnings; use Net::DBus; use Net::DBus::Binding::Message::MethodCall; use Net::DBus::Binding::Message::MethodReturn; use Net::DBus::Binding::Message::Error; use Net::DBus::Binding::Message::Signal; use Net::DBus::Binding::PendingCall; =item my $con = Net::DBus::Binding::Connection->new(address => "unix:path=/path/to/socket"); Creates a new connection to the remove server specified by the parameter C
. If the C parameter is supplied, and set to a True value the connection opened is private; otherwise a shared connection is opened. A private connection must be explicitly shutdown with the C method before the last reference to the object is released. A shared connection must never be explicitly disconnected. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; my $private = $params{private} ? $params{private} : 0; $self->{address} = exists $params{address} ? $params{address} : (exists $params{connection} ? "" : die "address parameter is required"); $self->{connection} = exists $params{connection} ? $params{connection} : ($private ? Net::DBus::Binding::Connection::_open_private($self->{address}) : Net::DBus::Binding::Connection::_open($self->{address})); bless $self, $class; $self->{connection}->_set_owner($self); return $self; } =item $status = $con->is_connected(); Returns zero if the connection has been disconnected, otherwise a positive value is returned. =cut sub is_connected { my $self = shift; return $self->{connection}->dbus_connection_get_is_connected(); } =item $status = $con->is_authenticated(); Returns zero if the connection has not yet successfully completed authentication, otherwise a positive value is returned. =cut sub is_authenticated { my $self = shift; return $self->{connection}->dbus_connection_get_is_authenticated(); } =item $con->disconnect() Closes this connection to the remote host. This method is called automatically during garbage collection (ie in the DESTROY method) if the programmer forgets to explicitly disconnect. =cut sub disconnect { my $self = shift; $self->{connection}->dbus_connection_disconnect(); } =item $con->flush() Blocks execution until all data in the outgoing data stream has been sent. This method will not re-enter the application event loop. =cut sub flush { my $self = shift; $self->{connection}->dbus_connection_flush(); } =item $con->send($message) Queues a message up for sending to the remote host. The data will be sent asynchronously as the applications event loop determines there is space in the outgoing socket send buffer. To force immediate sending of the data, follow this method will a call to C. This method will return the serial number of the message, which can be used to identify a subsequent reply (if any). =cut sub send { my $self = shift; my $msg = shift; return $self->{connection}->_send($msg->{message}); } =item my $reply = $con->send_with_reply_and_block($msg, $timeout); Queues a message up for sending to the remote host and blocks until it has been sent, and a corresponding reply received. The return value of this method will be a C or C object. =cut sub send_with_reply_and_block { my $self = shift; my $msg = shift; my $timeout = shift; my $reply = $self->{connection}->_send_with_reply_and_block($msg->{message}, $timeout); my $type = $reply->dbus_message_get_type; if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { return $self->make_raw_message($reply); } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { return $self->make_raw_message($reply); } else { die "unknown method reply type $type"; } } =item my $pending_call = $con->send_with_reply($msg, $timeout); Queues a message up for sending to the remote host and returns immediately providing a reference to a C object. This object can be used to wait / watch for a reply. This allows methods to be processed asynchronously. =cut sub send_with_reply { my $self = shift; my $msg = shift; my $timeout = shift; my $reply = $self->{connection}->_send_with_reply($msg->{message}, $timeout); return Net::DBus::Binding::PendingCall->new(connection => $self, method_call => $msg, pending_call => $reply); } =item $con->dispatch; Dispatches any pending messages in the incoming queue to their message handlers. This method is typically called on each iteration of the main application event loop where data has been read from the incoming socket. =cut sub dispatch { my $self = shift; $self->{connection}->_dispatch(); } =item $message = $con->borrow_message Temporarily removes the first message from the incoming message queue. No other thread may access the message while it is 'borrowed', so it should be replaced in the queue with the C method, or removed permanently with th C method as soon as is practical. =cut sub borrow_message { my $self = shift; my $msg = $self->{connection}->dbus_connection_borrow_message(); return $self->make_raw_message($msg); } =item $con->return_message($msg) Replaces a previously borrowed message in the incoming message queue for subsequent dispatch to registered message handlers. =cut sub return_message { my $self = shift; my $msg = shift; $self->{connection}->dbus_connection_return_message($msg->{message}); } =item $con->steal_message($msg) Permanently remove a borrowed message from the incoming message queue. No registered message handlers will now be run for this message. =cut sub steal_message { my $self = shift; my $msg = shift; $self->{connection}->dbus_connection_steal_borrowed_message($msg->{message}); } =item $msg = $con->pop_message(); Permanently removes the first message on the incoming message queue, without running any registered message handlers. If you have hooked the connection up to an event loop (C for example), you probably don't want to be calling this method. =cut sub pop_message { my $self = shift; my $msg = $self->{connection}->dbus_connection_pop_message(); return $self->make_raw_message($msg); } =item $con->set_watch_callbacks(\&add_watch, \&remove_watch, \&toggle_watch); Register a set of callbacks for adding, removing & updating watches in the application's event loop. Each parameter should be a code reference, which on each invocation, will be supplied with two parameters, the connection object and the watch object. If you are using a C object as the application event loop, then the 'manage' method on that object will call this on your behalf. =cut sub set_watch_callbacks { my $self = shift; my $add = shift; my $remove = shift; my $toggled = shift; $self->{add_watch} = $add; $self->{remove_watch} = $remove; $self->{toggled_watch} = $toggled; $self->{connection}->_set_watch_callbacks(); } =item $con->set_timeout_callbacks(\&add_timeout, \&remove_timeout, \&toggle_timeout); Register a set of callbacks for adding, removing & updating timeouts in the application's event loop. Each parameter should be a code reference, which on each invocation, will be supplied with two parameters, the connection object and the timeout object. If you are using a C object as the application event loop, then the 'manage' method on that object will call this on your behalf. =cut sub set_timeout_callbacks { my $self = shift; my $add = shift; my $remove = shift; my $toggled = shift; $self->{add_timeout} = $add; $self->{remove_timeout} = $remove; $self->{toggled_timeout} = $toggled; $self->{connection}->_set_timeout_callbacks(); } =item $con->register_object_path($path, \&handler) Registers a handler for messages whose path matches that specified in the C<$path> parameter. The supplied code reference will be invoked with two parameters, the connection object on which the message was received, and the message to be processed (an instance of the C class). =cut sub register_object_path { my $self = shift; my $path = shift; my $code = shift; my $callback = sub { my $con = shift; my $msg = shift; &$code($con, $self->make_raw_message($msg)); }; $self->{connection}->_register_object_path($path, $callback); } =item $con->unregister_object_path($path) Unregisters the handler associated with the object path C<$path>. The handler would previously have been registered with the C or C methods. =cut sub unregister_object_path { my $self = shift; my $path = shift; $self->{connection}->_unregister_object_path($path); } =item $con->register_fallback($path, \&handler) Registers a handler for messages whose path starts with the prefix specified in the C<$path> parameter. The supplied code reference will be invoked with two parameters, the connection object on which the message was received, and the message to be processed (an instance of the C class). =cut sub register_fallback { my $self = shift; my $path = shift; my $code = shift; my $callback = sub { my $con = shift; my $msg = shift; &$code($con, $self->make_raw_message($msg)); }; $self->{connection}->_register_fallback($path, $callback); } =item $con->set_max_message_size($bytes) Sets the maximum allowable size of a single incoming message. Messages over this size will be rejected prior to exceeding this threshold. The message size is specified in bytes. =cut sub set_max_message_size { my $self = shift; my $size = shift; $self->{connection}->dbus_connection_set_max_message_size($size); } =item $bytes = $con->get_max_message_size(); Retrieves the maximum allowable incoming message size. The returned size is measured in bytes. =cut sub get_max_message_size { my $self = shift; return $self->{connection}->dbus_connection_get_max_message_size; } =item $con->set_max_received_size($bytes) Sets the maximum size of the incoming message queue. Once this threashold is exceeded, no more messages will be read from wire before one or more of the existing messages are dispatched to their registered handlers. The implication is that the message queue can exceed this threshold by at most the size of a single message. =cut sub set_max_received_size { my $self = shift; my $size = shift; $self->{connection}->dbus_connection_set_max_received_size($size); } =item $bytes $con->get_max_received_size() Retrieves the maximum incoming message queue size. The returned size is measured in bytes. =cut sub get_max_received_size { my $self = shift; return $self->{connection}->dbus_connection_get_max_received_size; } =item $con->add_filter($coderef); Adds a filter to the connection which will be invoked whenever a message is received. The C<$coderef> should be a reference to a subroutine, which returns a true value if the message should be filtered out, or a false value if the normal message dispatch should be performed. =cut sub add_filter { my $self = shift; my $callback = shift; $self->{connection}->_add_filter($callback); } sub _message_filter { my $self = shift; my $rawmsg = shift; my $code = shift; my $msg = $self->make_raw_message($rawmsg); return &$code($self, $msg); } =item my $msg = $con->make_raw_message($rawmsg) Creates a new message, initializing it from the low level C message object provided by the C<$rawmsg> parameter. The returned object will be cast to the appropriate subclass of L. =cut sub make_raw_message { my $self = shift; my $rawmsg = shift; return Net::DBus::Binding::Message->new(message => $rawmsg); } =item my $msg = $con->make_error_message( replyto => $method_call, name => $name, description => $description); Creates a new message, representing an error which occurred during the handling of the method call object passed in as the C parameter. The C parameter is the formal name of the error condition, while the C is a short piece of text giving more specific information on the error. =cut sub make_error_message { my $self = shift; my $replyto = shift; my $name = shift; my $description = shift; return Net::DBus::Binding::Message::Error->new(replyto => $replyto, name => $name, description => $description); } =item my $call = $con->make_method_call_message( $service_name, $object_path, $interface, $method_name); Create a message representing a call on the object located at the path C<$object_path> within the client owning the well-known name given by C<$service_name>. The method to be invoked has the name C<$method_name> within the interface specified by the C<$interface> parameter. =cut sub make_method_call_message { my $self = shift; my $service_name = shift; my $object_path = shift; my $interface = shift; my $method_name = shift; return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name, object_path => $object_path, interface => $interface, method_name => $method_name); } =item my $msg = $con->make_method_return_message( replyto => $method_call); Create a message representing a reply to the method call passed in the C parameter. =cut sub make_method_return_message { my $self = shift; my $replyto = shift; return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto); } =item my $signal = $con->make_signal_message( object_path => $path, interface => $interface, signal_name => $name); Creates a new message, representing a signal [to be] emitted by the object located under the path given by the C parameter. The name of the signal is given by the C parameter, and is scoped to the interface given by the C parameter. =cut sub make_signal_message { my $self = shift; my $object_path = shift; my $interface = shift; my $signal_name = shift; return Net::DBus::Binding::Message::Signal->new(object_path => $object_path, interface => $interface, signal_name => $signal_name); } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L, L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Server.pm0000644000076500007650000001246411603165524020560 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Server - A server to accept incoming connections =head1 SYNOPSIS Creating a new server and accepting client connections use Net::DBus::Binding::Server; my $server = Net::DBus::Binding::Server->new(address => "unix:path=/path/to/socket"); $server->connection_callback(\&new_connection); sub new_connection { my $connection = shift; .. work with new connection... } Managing the server and new connections in an event loop my $reactor = Net::DBus::Binding::Reactor->new(); $reactor->manage($server); $reactor->run(); sub new_connection { my $connection = shift; $reactor->manage($connection); } =head1 DESCRIPTION A server for receiving connection from client programs. The methods defined on this module have a close correspondance to the dbus_server_XXX methods in the C API, so for further details on their behaviour, the C API documentation may be of use. =head1 METHODS =over =cut package Net::DBus::Binding::Server; use 5.006; use strict; use warnings; use Net::DBus; use Net::DBus::Binding::Connection; =item my $server = Net::DBus::Binding::Server->new(address => "unix:path=/path/to/socket"); Creates a new server binding it to the socket specified by the C
parameter. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{address} = exists $params{address} ? $params{address} : die "address parameter is required"; $self->{server} = Net::DBus::Binding::Server::_open($self->{address}); bless $self, $class; $self->{server}->_set_owner($self); $self->{_callback} = sub { my $server = shift; my $rawcon = shift; my $con = Net::DBus::Binding::Connection->new(connection => $rawcon); if ($server->{connection_callback}) { &{$server->{connection_callback}}($server, $con); } }; return $self; } =item $status = $server->is_connected(); Returns zero if the server has been disconnected, otherwise a positive value is returned. =cut sub is_connected { my $self = shift; return $self->{server}->dbus_server_get_is_connected(); } =item $server->disconnect() Closes this server to the remote host. This method is called automatically during garbage collection (ie in the DESTROY method) if the programmer forgets to explicitly disconnect. =cut sub disconnect { my $self = shift; return $self->{server}->dbus_server_disconnect(); } =item $server->set_watch_callbacks(\&add_watch, \&remove_watch, \&toggle_watch); Register a set of callbacks for adding, removing & updating watches in the application's event loop. Each parameter should be a code reference, which on each invocation, will be supplied with two parameters, the server object and the watch object. If you are using a C object as the application event loop, then the 'manage' method on that object will call this on your behalf. =cut sub set_watch_callbacks { my $self = shift; my $add = shift; my $remove = shift; my $toggled = shift; $self->{add_watch} = $add; $self->{remove_watch} = $remove; $self->{toggled_watch} = $toggled; $self->{server}->_set_watch_callbacks(); } =item $server->set_timeout_callbacks(\&add_timeout, \&remove_timeout, \&toggle_timeout); Register a set of callbacks for adding, removing & updating timeouts in the application's event loop. Each parameter should be a code reference, which on each invocation, will be supplied with two parameters, the server object and the timeout object. If you are using a C object as the application event loop, then the 'manage' method on that object will call this on your behalf. =cut sub set_timeout_callbacks { my $self = shift; my $add = shift; my $remove = shift; my $toggled = shift; $self->{add_timeout} = $add; $self->{remove_timeout} = $remove; $self->{toggled_timeout} = $toggled; $self->{server}->_set_timeout_callbacks(); } =item $server->set_connection_callback(\&handler) Registers the handler to use for dealing with new incoming connections from clients. The code reference will be invoked each time a new client connects and supplied with a single parameter which is the C object representing the client. =cut sub set_connection_callback { my $self = shift; my $callback = shift; $self->{connection_callback} = $callback; $self->{server}->_set_connection_callback(); } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L, L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/PendingCall.pm0000644000076500007650000000760311603165524021471 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2006-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::PendingCall - A handler for pending method replies =head1 SYNOPSIS my $call = Net::DBus::Binding::PendingCall->new(method_call => $call, pending_call => $reply); # Wait for completion $call->block; # And get the reply message my $msg = $call->get_reply; =head1 DESCRIPTION This object is used when it is necessary to make asynchronous method calls. It provides the means to be notified when the reply is finally received. =head1 METHODS =over 4 =cut package Net::DBus::Binding::PendingCall; use 5.006; use strict; use warnings; use Net::DBus; use Net::DBus::Binding::Message::MethodReturn; use Net::DBus::Binding::Message::Error; =item my $call = Net::DBus::Binding::PendingCall->new(method_call => $method_call, pending_call => $pending_call); Creates a new pending call object, with the C parameter being a reference to the C object whose reply is being waiting for. The C parameter is a reference to the raw C pending call object. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{connection} = exists $params{connection} ? $params{connection} : die "connection parameter is required"; $self->{method_call} = exists $params{method_call} ? $params{method_call} : die "method_call parameter is required"; $self->{pending_call} = exists $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required"; bless $self, $class; return $self; } =item $call->cancel Cancel the pending call, causing any reply that is later received to be discarded. =cut sub cancel { my $self = shift; $self->{pending_call}->dbus_pending_call_cancel(); } =item my $boolean = $call->get_completed Returns a true value if the pending call has received its reply, or a timeout has occurred. =cut sub get_completed { my $self = shift; $self->{pending_call}->dbus_pending_call_get_completed(); } =item $call->block Block the caller until the reply is received or a timeout occurrs. =cut sub block { my $self = shift; $self->{pending_call}->dbus_pending_call_block(); } =item my $msg = $call->get_reply; Retrieves the C object associated with the complete call. =cut sub get_reply { my $self = shift; my $reply = $self->{pending_call}->_steal_reply(); my $type = $reply->dbus_message_get_type; if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { return $self->{connection}->make_raw_message($reply); } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { return $self->{connection}->make_raw_message($reply); } else { die "unknown method reply type $type"; } } =item $call->set_notify($coderef); Sets a notification function to be invoked when the pending call completes. The callback will be passed a single argument which is this pending call object. =cut sub set_notify { my $self = shift; my $cb = shift; $self->{pending_call}->_set_notify($cb); } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2006-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Bus.pm0000644000076500007650000001077111603165524020042 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Bus - Handle to a well-known message bus instance =head1 SYNOPSIS use Net::DBus::Binding::Bus; # Get a handle to the system bus my $bus = Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM); =head1 DESCRIPTION This is a specialization of the L module providing convenience constructor for connecting to one of the well-known bus types. There is no reason to use this module directly, instead get a handle to the bus with the C or C methods in L. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Bus; use 5.006; use strict; use warnings; use Net::DBus; use base qw(Net::DBus::Binding::Connection); =item my $bus = Net::DBus::Binding::Bus->new(type => $type); =item my $bus = Net::DBus::Binding::Bus->new(address => $addr); Open a connection to a message bus, either a well known bus type specified using the C parameter, or an arbitrary bus specified using the C
parameter. If the C parameter is set to a true value, then a private connection to the bus is obtained. The caller must explicitly disconnect this bus instance before releasing the last instance of the object. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $connection; if (defined $params{type}) { if ($params{private}) { $connection = Net::DBus::Binding::Bus::_open_private($params{type}); } else { $connection = Net::DBus::Binding::Bus::_open($params{type}); } } elsif (defined $params{address}) { if ($params{private}) { $connection = Net::DBus::Binding::Connection::_open_private($params{address}); } else { $connection = Net::DBus::Binding::Connection::_open($params{address}); } $connection->dbus_bus_register(); } else { die "either type or address parameter is required"; } my $self = $class->SUPER::new(%params, connection => $connection); bless $self, $class; return $self; } =item $bus->request_name($service_name) Send a request to the bus registering the well known name specified in the C<$service_name> parameter. If another client already owns the name, registration will be queued up, pending the exit of the other client. =cut sub request_name { my $self = shift; my $service_name = shift; $self->{connection}->dbus_bus_request_name($service_name); } =item my $name = $bus->get_unique_name Returns the unique name by which this processes' connection to the bus is known. Unique names are never re-used for the entire lifetime of the bus daemon. =cut sub get_unique_name { my $self = shift; $self->{connection}->dbus_bus_get_unique_name; } =item $bus->add_match($rule) Register a signal match rule with the bus controller, allowing matching broadcast signals to routed to this client. =cut sub add_match { my $self = shift; my $rule = shift; $self->{connection}->dbus_bus_add_match($rule); } =item $bus->remove_match($rule) Unregister a signal match rule with the bus controller, preventing further broadcast signals being routed to this client =cut sub remove_match { my $self = shift; my $rule = shift; $self->{connection}->dbus_bus_remove_match($rule); } sub DESTROY { # Keep autoloader quiet } sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; die "&Net::DBus::Binding::Bus::constant not defined" if $constname eq '_constant'; if (!exists $Net::DBus::Binding::Bus::_constants{$constname}) { die "no such method $constname, and no constant \$Net::DBus::Binding::Bus::$constname"; } { no strict 'refs'; *$AUTOLOAD = sub { $Net::DBus::Binding::Bus::_constants{$constname} }; } goto &$AUTOLOAD; } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Value.pm0000644000076500007650000000422011603165524020355 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Value - Strongly typed data value =head1 SYNOPSIS # Import the convenience functions use Net::DBus qw(:typing); # Call a method with passing an int32 $object->doit(dint32("3")); =head1 DESCRIPTION This module provides a simple wrapper around a raw Perl value, associating an explicit DBus type with the value. This is used in cases where a client is communicating with a server which does not provide introspection data, but for which the basic data types are not sufficient. This class should not be used directly, rather the convenience functions in L be called. =head1 METHODS =over 4 =cut package Net::DBus::Binding::Value; use strict; use warnings; =item my $value = Net::DBus::Binding::Value->new($type, $value); Creates a wrapper for the perl value C<$value> marking it as having the dbus data type C<$type>. It is not neccessary to call this method directly, instead the data typing methods in the L object should be used. =cut sub new { my $class = shift; my $self = []; $self->[0] = shift; $self->[1] = shift; bless $self, $class; return $self; } =item my $raw = $value->value Returns the raw perl value wrapped by this object =cut sub value { my $self = shift; return $self->[1]; } =item my $type = $value->type Returns the dbus data type this value is marked as having =cut sub type { my $self = shift; return $self->[0]; } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Binding/Iterator.pm0000644000076500007650000004534211603165524021104 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Binding::Iterator - Reading and writing message parameters =head1 SYNOPSIS Creating a new message my $msg = new Net::DBus::Binding::Message::Signal; my $iterator = $msg->iterator; $iterator->append_boolean(1); $iterator->append_byte(123); Reading from a mesage my $msg = ...get it from somewhere... my $iter = $msg->iterator(); my $i = 0; while ($iter->has_next()) { $iter->next(); $i++; if ($i == 1) { my $val = $iter->get_boolean(); } elsif ($i == 2) { my $val = $iter->get_byte(); } } =head1 DESCRIPTION Provides an iterator for reading or writing message fields. This module provides a Perl API to access the dbus_message_iter_XXX methods in the C API. The array and dictionary types are not yet supported, and there are bugs in the Quad support (ie it always returns -1!). =head1 METHODS =over 4 =cut package Net::DBus::Binding::Iterator; use 5.006; use strict; use warnings; use Net::DBus; =item $res = $iter->has_next() Determines if there are any more fields in the message itertor to be read. Returns a positive value if there are more fields, zero otherwise. =item $success = $iter->next() Skips the iterator onto the next field in the message. Returns a positive value if the current field pointer was successfully advanced, zero otherwise. =item my $val = $iter->get_boolean() =item $iter->append_boolean($val); Read or write a boolean value from/to the message iterator =item my $val = $iter->get_byte() =item $iter->append_byte($val); Read or write a single byte value from/to the message iterator. =item my $val = $iter->get_string() =item $iter->append_string($val); Read or write a UTF-8 string value from/to the message iterator =item my $val = $iter->get_object_path() =item $iter->append_object_path($val); Read or write a UTF-8 string value, whose contents is a valid object path, from/to the message iterator =item my $val = $iter->get_signature() =item $iter->append_signature($val); Read or write a UTF-8 string, whose contents is a valid type signature, value from/to the message iterator =item my $val = $iter->get_int16() =item $iter->append_int16($val); Read or write a signed 16 bit value from/to the message iterator =item my $val = $iter->get_uint16() =item $iter->append_uint16($val); Read or write an unsigned 16 bit value from/to the message iterator =item my $val = $iter->get_int32() =item $iter->append_int32($val); Read or write a signed 32 bit value from/to the message iterator =item my $val = $iter->get_uint32() =item $iter->append_uint32($val); Read or write an unsigned 32 bit value from/to the message iterator =item my $val = $iter->get_int64() =item $iter->append_int64($val); Read or write a signed 64 bit value from/to the message iterator. An error will be raised if this build of Perl does not support 64 bit integers =item my $val = $iter->get_uint64() =item $iter->append_uint64($val); Read or write an unsigned 64 bit value from/to the message iterator. An error will be raised if this build of Perl does not support 64 bit integers =item my $val = $iter->get_double() =item $iter->append_double($val); Read or write a double precision floating point value from/to the message iterator =cut sub get_int64 { my $self = shift; return $self->_get_int64; } sub get_uint64 { my $self = shift; return $self->_get_uint64; } sub append_int64 { my $self = shift; $self->_append_int64(shift); } sub append_uint64 { my $self = shift; $self->_append_uint64(shift); } =item my $value = $iter->get() =item my $value = $iter->get($type); Get the current value pointed to by this iterator. If the optional C<$type> parameter is supplied, the wire type will be compared with the desired type & a warning output if their differ. The C<$type> value must be one of the C constants. =cut sub get { my $self = shift; my $type = shift; if (defined $type) { if (ref($type)) { if (ref($type) eq "ARRAY") { # XXX we should recursively validate types $type = $type->[0]; if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $type = &Net::DBus::Binding::Message::TYPE_ARRAY; } } else { die "unsupport type reference $type"; } } my $actual = $self->get_arg_type; if ($actual != $type) { # "Be strict in what you send, be leniant in what you accept" # - ie can't rely on python to send correct types, eg int32 vs uint32 # But, don't complain for variants because a number of apps (eg HAL) # claim to return variants, but in fact don't correctly encode their # data as variants. Technically a bug in the server, but it does # 'just work' normally. warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)" if $type != &Net::DBus::Binding::Message::TYPE_VARIANT; $type = $actual; } } else { $type = $self->get_arg_type; } if ($type == &Net::DBus::Binding::Message::TYPE_STRING) { return $self->get_string; } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { return $self->get_boolean; } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { return $self->get_byte; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { return $self->get_int16; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { return $self->get_uint16; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { return $self->get_int32; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { return $self->get_uint32; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { return $self->get_int64; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { return $self->get_uint64; } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { return $self->get_double; } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) { my $array_type = $self->get_element_type(); if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { return $self->get_dict(); } else { return $self->get_array($array_type); } } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) { return $self->get_struct(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) { return $self->get_variant(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { die "dictionary can only occur as part of an array type"; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) { die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID"; } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { return $self->get_object_path(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { return $self->get_signature(); } else { die "unknown argument type '" . chr($type) . "' ($type)"; } } =item my $hashref = $iter->get_dict() If the iterator currently points to a dictionary value, unmarshalls and returns the value as a hash reference. =cut sub get_dict { my $self = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $dict = {}; while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { my $entry = $iter->get_struct(); if ($#{$entry} != 1) { die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements"; } $dict->{$entry->[0]} = $entry->[1]; $iter->next(); $type = $iter->get_arg_type(); } return $dict; } =item my $hashref = $iter->get_array() If the iterator currently points to an array value, unmarshalls and returns the value as a array reference. =cut sub get_array { my $self = shift; my $array_type = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $array = []; while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { if ($type != $array_type) { die "Element $type not of array type $array_type"; } my $value = $iter->get($type); push @{$array}, $value; $iter->next(); $type = $iter->get_arg_type(); } return $array; } =item my $hashref = $iter->get_variant() If the iterator currently points to a variant value, unmarshalls and returns the value contained in the variant. =cut sub get_variant { my $self = shift; my $iter = $self->_recurse(); return $iter->get(); } =item my $hashref = $iter->get_struct() If the iterator currently points to an struct value, unmarshalls and returns the value as a array reference. The values in the array correspond to members of the struct. =cut sub get_struct { my $self = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $struct = []; while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { my $value = $iter->get($type); push @{$struct}, $value; $iter->next(); $type = $iter->get_arg_type(); } return $struct; } =item $iter->append($value) =item $iter->append($value, $type) Appends a value to the message associated with this iterator. The value is marshalled into wire format, according to the following rules. If the C<$value> is an instance of L, the embedded data type is used. If the C<$type> parameter is supplied, that is taken to represent the data type. The type must be one of the C constants. Otherwise, the data type is chosen to be a string, dict or array according to the perl data types SCALAR, HASH or ARRAY. =cut sub append { my $self = shift; my $value = shift; my $type = shift; if (ref($value) eq "Net::DBus::Binding::Value" && ((! defined ref($type)) || (ref($type) ne "ARRAY") || $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) { $type = $value->type; $value = $value->value; } if (!defined $type) { $type = $self->guess_type($value); } if (ref($type) eq "ARRAY") { my $maintype = $type->[0]; my $subtype = $type->[1]; if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $self->append_dict($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { $self->append_struct($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { $self->append_array($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { $self->append_variant($value, $subtype); } else { die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')"; } } else { # XXX is this good idea or not $value = '' unless defined $value; if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { $self->append_boolean($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { $self->append_byte($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) { $self->append_string($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { $self->append_int16($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { $self->append_uint16($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { $self->append_int32($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { $self->append_uint32($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { $self->append_int64($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { $self->append_uint64($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { $self->append_double($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { $self->append_object_path($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { $self->append_signature($value); } else { die "Unsupported scalar type ", $type, " ('", chr($type), "')"; } } } =item my $type = $iter->guess_type($value) Make a best guess at the on the wire data type to use for marshalling C<$value>. If the value is a hash reference, the dictionary type is returned; if the value is an array reference the array type is returned; otherwise the string type is returned. =cut sub guess_type { my $self = shift; my $value = shift; if (ref($value)) { if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { my $type = $value->type; if (ref($type) && ref($type) eq "ARRAY") { my $maintype = $type->[0]; my $subtype = $type->[1]; if (!defined $subtype) { if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $subtype = [ $self->guess_type(($value->value())[0]->[0]), $self->guess_type(($value->value())[0]->[1]) ]; } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { $subtype = [ $self->guess_type(($value->value())[0]->[0]) ]; } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ]; } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { $subtype = $self->guess_type($value->value); } else { die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n"; } } return [$maintype, $subtype]; } else { return $type; } } elsif (ref($value) eq "HASH") { my $key = (keys %{$value})[0]; my $val = $value->{$key}; # XXX Basically impossible to decide between DICT & STRUCT return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ]; } elsif (ref($value) eq "ARRAY") { return [ &Net::DBus::Binding::Message::TYPE_ARRAY, [$self->guess_type($value->[0])] ]; } else { die "cannot marshall reference of type " . ref($value); } } else { # XXX Should we bother trying to guess integer & floating point types ? # I say sod it, because strongly typed languages will support introspection # and loosely typed languages won't care about the difference return &Net::DBus::Binding::Message::TYPE_STRING; } } =item my $sig = $iter->format_signature($type) Given a data type representation, construct a corresponding signature string =cut sub format_signature { my $self = shift; my $type = shift; my ($sig, $t, $i); $sig = ""; $i = 0; if (ref($type) eq "ARRAY") { while ($i <= $#{$type}) { $t = $$type[$i]; if (ref($t) eq "ARRAY") { $sig .= $self->format_signature($t); } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY); $sig .= "{" . $self->format_signature($$type[++$i]) . "}"; } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) { $sig .= "(" . $self->format_signature($$type[++$i]) . ")"; } else { $sig .= chr($t); } $i++; } } else { $sig .= chr ($type); } return $sig; } =item $iter->append_array($value, $type) Append an array of values to the message. The C<$value> parameter must be an array reference, whose elements all have the same data type specified by the C<$type> parameter. =cut sub append_array { my $self = shift; my $array = shift; my $type = shift; if (!defined($type)) { $type = [$self->guess_type($array->[0])]; } die "array must only have one type" if $#{$type} > 0; my $sig = $self->format_signature($type); my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); foreach my $value (@{$array}) { $iter->append($value, $type->[0]); } $self->_close_container($iter); } =item $iter->append_struct($value, $type) Append a struct to the message. The C<$value> parameter must be an array reference, whose elements correspond to members of the structure. The C<$type> parameter encodes the type of each member of the struct. =cut sub append_struct { my $self = shift; my $struct = shift; my $type = shift; if (defined($type) && $#{$struct} != $#{$type}) { die "number of values does not match type"; } my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, ""); my @type = defined $type ? @{$type} : (); foreach my $value (@{$struct}) { $iter->append($value, shift @type); } $self->_close_container($iter); } =item $iter->append_dict($value, $type) Append a dictionary to the message. The C<$value> parameter must be an hash reference.The C<$type> parameter encodes the type of the key and value of the hash. =cut sub append_dict { my $self = shift; my $hash = shift; my $type = shift; my $sig; $sig = "{"; $sig .= $self->format_signature($type); $sig .= "}"; my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); foreach my $key (keys %{$hash}) { my $value = $hash->{$key}; my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, ""); $entry->append($key, $type->[0]); $entry->append($value, $type->[1]); $iter->_close_container($entry); } $self->_close_container($iter); } =item $iter->append_variant($value) Append a value to the message, encoded as a variant type. The C<$value> can be of any type, however, the variant will be encoded as either a string, dictionary or array according to the rules of the C method. =cut sub append_variant { my $self = shift; my $value = shift; my $type = shift; if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { $type = [$self->guess_type($value)]; $value = $value->value; } elsif (!defined $type || !defined $type->[0]) { $type = [$self->guess_type($value)]; } die "variant must only have one type" if defined $type && $#{$type} > 0; my $sig = $self->format_signature($type->[0]); my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig); $iter->append($value, $type->[0]); $self->_close_container($iter); } =item my $type = $iter->get_arg_type Retrieves the type code of the value pointing to by this iterator. The returned code will correspond to one of the constants C =item my $type = $iter->get_element_type If the iterator points to an array, retrieves the type code of array elements. The returned code will correspond to one of the constants C =cut 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2011 Daniel P. Berrange =head1 SEE ALSO L =cut Net-DBus-1.0.0/lib/Net/DBus/RemoteObject.pm0000644000076500007650000003237711603165524020327 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::RemoteObject - Access objects provided on the bus =head1 SYNOPSIS my $service = $bus->get_service("org.freedesktop.DBus"); my $object = $service->get_object("/org/freedesktop/DBus"); print "Names on the bus {\n"; foreach my $name (sort @{$object->ListNames}) { print " ", $name, "\n"; } print "}\n"; =head1 DESCRIPTION This module provides the API for accessing remote objects available on the bus. It uses the autoloader to fake the presence of methods based on the API of the remote object. There is also support for setting callbacks against signals, and accessing properties of the object. =head1 METHODS =over 4 =cut package Net::DBus::RemoteObject; use 5.006; use strict; use warnings; our $AUTOLOAD; use Net::DBus::Binding::Introspector; use Net::DBus::ASyncReply; use Net::DBus::Annotation qw(:call); =item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface]); Creates a new handle to a remote object. The C<$service> parameter is an instance of the L method, and C<$object_path> is the identifier of an object exported by this service, for example C. For remote objects which implement more than one interface it is possible to specify an optional name of an interface as the third parameter. This is only really required, however, if two interfaces in the object provide methods with the same name, since introspection data can be used to automatically resolve the correct interface to call cases where method names are unique. Rather than using this constructor directly, it is preferrable to use the C method on L, since this caches handles to remote objects, eliminating unneccessary introspection data lookups. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; $self->{service} = shift; $self->{object_path} = shift; $self->{interface} = @_ ? shift : undef; $self->{introspected} = 0; $self->{signal_handlers} = {}; $self->{signal_id} = 0; bless $self, $class; return $self; } =item my $object = $object->as_interface($interface); Casts the object to a specific interface, returning a new instance of the L specialized to the desired interface. It is only neccessary to cast objects to a specific interface, if two interfaces export methods or signals with the same name, or the remote object does not support introspection. =cut sub as_interface { my $self = shift; my $interface = shift; die "already cast to " . $self->{interface} . "'" if $self->{interface}; return $self->new($self->{service}, $self->{object_path}, $interface); } =item my $service = $object->get_service Retrieves a handle for the remote service on which this object is attached. The returned object is an instance of L =cut sub get_service { my $self = shift; return $self->{service}; } =item my $path = $object->get_object_path Retrieves the unique path identifier for this object within the service. =cut sub get_object_path { my $self = shift; return $self->{object_path}; } =item my $object = $object->get_child_object($subpath, [$interface]) Retrieves a handle to a child of this object, identified by the relative path C<$subpath>. The returned object is an instance of C. The optional C<$interface> parameter can be used to immediately cast the object to a specific type. =cut sub get_child_object { my $self = shift; my $path = shift; my $interface = @_ ? shift : undef; my $fullpath = $self->{object_path} . $path; return $self->new($self->get_service, $fullpath, $interface); } sub _introspector { my $self = shift; unless ($self->{introspected}) { my $con = $self->{service}->get_bus()->get_connection(); my $call = $con->make_method_call_message($self->{service}->get_service_name(), $self->{object_path}, "org.freedesktop.DBus.Introspectable", "Introspect"); my $xml = eval { my $reply = $con->send_with_reply_and_block($call, 60 * 1000); my $iter = $reply->iterator; return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING); }; if ($@) { if (UNIVERSAL::isa($@, "Net::DBus::Error") && $@->{name} eq "org.freedesktop.DBus.Error.ServiceUnknown") { die $@; } else { # Ignore other failures, since its probably # just that the object doesn't implement # the introspect method. Of course without # the introspect method we can't tell for sure # if this is the case.. #warn "could not introspect object: $@"; } } if ($xml) { $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml, object_path => $self->{object_path}); } $self->{introspected} = 1; } return $self->{introspector}; } =item my $sigid = $object->connect_to_signal($name, $coderef); Connects a callback to a signal emitted by the object. The C<$name> parameter is the name of the signal within the object, and C<$coderef> is a reference to an anonymous subroutine. When the signal C<$name> is emitted by the remote object, the subroutine C<$coderef> will be invoked, and passed the parameters from the signal. A unique C<$sigid> will be returned, which can be later passed to C to remove the handler =cut sub connect_to_signal { my $self = shift; my $name = shift; my $code = shift; my $ins = $self->_introspector; my $interface = $self->{interface}; if (!$interface) { if (!$ins) { die "no introspection data available for '" . $self->get_object_path . "', and object is not cast to any interface"; } my @interfaces = $ins->has_signal($name); if ($#interfaces == -1) { die "no signal with name '$name' is exported in object '" . $self->get_object_path . "'\n"; } elsif ($#interfaces > 0) { warn "signal with name '$name' is exported " . "in multiple interfaces of '" . $self->get_object_path . "'" . "connecting to first interface only\n"; } $interface = $interfaces[0]; } if ($ins && $ins->has_signal($name, $interface) && $ins->is_signal_deprecated($name, $interface)) { warn "signal $name in interface $interface on " . $self->get_object_path . " is deprecated"; } my $cb = sub { my $signal = shift; my $ins = $self->_introspector; my @params; if ($ins) { @params = $ins->decode($signal, "signals", $signal->get_member, "params"); } else { @params = $signal->get_args_list; } foreach my $handler (@{$self->{signal_handlers}->{$signal->get_member}->{handlers}}) { my ($id, $cb) = @{$handler}; &$cb(@params); } }; if (!exists $self->{signal_handlers}->{$name}) { $self->{signal_handlers}->{$name} = { cb => $cb, handlers => [] }; $self->get_service-> get_bus()-> _add_signal_receiver($cb, $name, $interface, $self->{service}->get_service_name(), $self->{object_path}); } my $sigid = ++$self->{signal_id}; push @{$self->{signal_handlers}->{$name}->{handlers}}, [$sigid, $code]; return $sigid; } =item $object->disconnect_from_signal($name, $sigid); Disconnects from a signal emitted by the object. The C<$name> parameter is the name of the signal within the object. The C<$sigid> must be the unique signal handler ID returned by a previous C method call. =cut sub disconnect_from_signal { my $self = shift; my $name = shift; my $sigid = shift; my $ins = $self->_introspector; my $interface = $self->{interface}; if (!$interface) { if (!$ins) { die "no introspection data available for '" . $self->get_object_path . "', and object is not cast to any interface"; } my @interfaces = $ins->has_signal($name); if ($#interfaces == -1) { die "no signal with name '$name' is exported in object '" . $self->get_object_path . "'\n"; } elsif ($#interfaces > 0) { warn "signal with name '$name' is exported " . "in multiple interfaces of '" . $self->get_object_path . "'" . "connecting to first interface only\n"; } $interface = $interfaces[0]; } my @handlers; foreach my $handler (@{$self->{signal_handlers}->{$name}->{handlers}}) { my ($thissigid, $cb) = @{$handler}; if ($thissigid != $sigid) { push @handlers, $handler; } } if (@handlers) { $self->{signal_handlers}->{$name}->{handlers} = \@handlers; } else { $self->get_service-> get_bus()-> _remove_signal_receiver($self->{signal_handlers}->{$name}->{cb}, $name, $interface, $self->{service}->get_service_name(), $self->{object_path}); delete $self->{signal_handlers}->{$name}; } } sub DESTROY { # No op merely to stop AutoLoader trying to # call DESTROY on remote object } sub AUTOLOAD { my $self = shift; my $sub = $AUTOLOAD; my $mode = dbus_call_sync; if (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) { $mode = shift; } (my $name = $AUTOLOAD) =~ s/.*:://; my $interface = $self->{interface}; # If introspection data is available, use that # to resolve correct interface (if object is not # cast to an explicit interface already) my $ins = $self->_introspector(); if ($ins) { if ($interface) { if ($ins->has_method($name, $interface)) { return $self->_call_method($mode, $name, $interface, 1, @_); } if ($ins->has_property($name, $interface)) { if ($ins->is_property_deprecated($name, $interface)) { warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated"; } if (@_) { $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]); return (); } else { return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name); } } } else { my @interfaces = $ins->has_method($name); if (@interfaces) { if ($#interfaces > 0) { die "method with name '$name' is exported " . "in multiple interfaces of '" . $self->get_object_path . "'"; } return $self->_call_method($mode, $name, $interfaces[0], 1, @_); } @interfaces = $ins->has_property($name); if (@interfaces) { if ($#interfaces > 0) { die "property with name '$name' is exported " . "in multiple interfaces of '" . $self->get_object_path . "'"; } $interface = $interfaces[0]; if ($ins->is_property_deprecated($name, $interface)) { warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated"; } if (@_) { $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]); return (); } else { return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name); } } } } if (!$interface) { die "no introspection data available for method '" . $name . "' in object '" . $self->get_object_path . "', and object is not cast to any interface"; } return $self->_call_method($mode, $name, $interface, 0, @_); } sub _call_method { my $self = shift; my $mode = shift; my $name = shift; my $interface = shift; my $introspect = shift; my $con = $self->{service}->get_bus()->get_connection(); my $ins = $introspect ? $self->_introspector : undef; if ($ins && $ins->is_method_deprecated($name, $interface)) { warn "method '$name' in interface $interface on object " . $self->get_object_path . " is deprecated\n"; } my $call = $con->make_method_call_message($self->{service}->get_service_name(), $self->{object_path}, $interface, $name); #$call->set_destination($self->get_service->get_owner_name); if ($ins) { $ins->encode($call, "methods", $name, "params", @_); } else { $call->append_args_list(@_); } if ($mode == dbus_call_sync) { my $reply = $con-> send_with_reply_and_block($call, 60 * 1000); my @reply; if ($ins) { @reply = $ins->decode($reply, "methods", $name, "returns"); } else { @reply = $reply->get_args_list; } return wantarray ? @reply : $reply[0]; } elsif ($mode == dbus_call_async) { my $pending_call = $self->{service}-> get_bus()-> get_connection()-> send_with_reply($call, 60 * 1000); my $reply = Net::DBus::ASyncReply->_new(pending_call => $pending_call, ($ins ? (introspector => $ins, method_name => $name) : ())); return $reply; } elsif ($mode == dbus_call_noreply) { $call->set_no_reply(1); $self->{service}-> get_bus()-> get_connection()-> send($call, 60 * 1000); } else { die "unsupported annotation '$mode'"; } } 1; =pod =back =head1 AUTHOR Daniel Berrange =head1 COPYRIGHT Copright (C) 2004-2011, Daniel Berrange. =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Test/0000755000076500007650000000000011603165554016315 5ustar berrangeberrangeNet-DBus-1.0.0/lib/Net/DBus/Test/MockConnection.pm0000644000076500007650000002760111603165524021567 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Test::MockConnection - Fake a connection to the bus unit testing =head1 SYNOPSIS use Net::DBus; my $bus = Net::DBus->test # Register a service, and the objec to be tested use MyObject my $service = $bus->export_service("org.example.MyService"); my $object = MyObject->new($service); # Acquire the service & do tests my $remote_service = $bus->get_service('org.example.MyService'); my $remote_object = $service->get_object("/org/example/MyObjct"); # This traverses the mock connection, eventually # invoking 'testSomething' on the $object above. $remote_object->testSomething() =head1 DESCRIPTION This object provides a fake implementation of the L enabling a pure 'in-memory' message bus to be mocked up. This is intended to facilitate creation of unit tests for services which would otherwise need to call out to other object on a live message bus. It is used as a companion to the L module which is how fake objects are to be provided on the fake bus. =head1 METHODS =over 4 =cut package Net::DBus::Test::MockConnection; use strict; use warnings; use Net::DBus::Error; use Net::DBus::Test::MockMessage; use Net::DBus::Binding::Message::MethodCall; use Net::DBus::Binding::Message::MethodReturn; use Net::DBus::Binding::Message::Error; use Net::DBus::Binding::Message::Signal; =item my $con = Net::DBus::Test::MockConnection->new() Create a new mock connection object instance. It is not usually neccessary to create instances of this object directly, instead the C method on the L object can be used to get a handle to a test bus. =cut sub new { my $class = shift; my $self = {}; $self->{replies} = []; $self->{signals} = []; $self->{objects} = {}; $self->{objectTrees} = {}; $self->{filters} = []; bless $self, $class; return $self; } =item $con->send($message) Send a message over the mock connection. If the message is a method call, it will be dispatched straight to any corresponding mock object registered. If the mesage is an error or method return it will be made available as a return value for the C method. If the message is a signal it will be queued up for processing by the C method. =cut sub send { my $self = shift; my $msg = shift; if ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL) { $self->_call_method($msg); } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN || $msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { push @{$self->{replies}}, $msg; } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL) { push @{$self->{signals}}, $msg; } else { die "unhandled type of message " . ref($msg); } } =item $bus->request_name($service_name) Pretend to send a request to the bus registering the well known name specified in the C<$service_name> parameter. In reality this is just a no-op giving the impression that the name was successfully registered. =cut sub request_name { my $self = shift; my $name = shift; my $flags = shift; # XXX do we care about this for test cases? probably not... # ....famous last words } =item my $reply = $con->send_with_reply_and_block($msg) Send a message over the mock connection and wait for a reply. The C<$msg> should be an instance of C and the return C<$reply> will be an instance of C. It is also possible that an error will be thrown, with the thrown error being blessed into the C class. =cut sub send_with_reply_and_block { my $self = shift; my $msg = shift; my $timeout = shift; $self->send($msg); if ($#{$self->{replies}} == -1) { die "no reply for " . $msg->get_path . "->" . $msg->get_member . " received within timeout"; } my $reply = shift @{$self->{replies}}; if ($#{$self->{replies}} != -1) { die "too many replies received"; } if ($reply->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { my $iter = $reply->iterator; my $desc = $iter->get_string; die Net::DBus::Error->new(name => $reply->get_error_name, message => $desc); } return $reply; } =item $con->dispatch; Dispatches any pending messages in the incoming queue to their message handlers. This method should be called by test suites whenever they anticipate that there are pending signals to be dealt with. =cut sub dispatch { my $self = shift; my @signals = @{$self->{signals}}; $self->{signals} = []; foreach my $msg (@signals) { foreach my $cb (@{$self->{filters}}) { # XXX we should worry about return value... &$cb($self, $msg); } } } =item $con->add_filter($coderef); Adds a filter to the connection which will be invoked whenever a message is received. The C<$coderef> should be a reference to a subroutine, which returns a true value if the message should be filtered out, or a false value if the normal message dispatch should be performed. =cut sub add_filter { my $self = shift; my $cb = shift; push @{$self->{filters}}, $cb; } =item $bus->add_match($rule) Register a signal match rule with the bus controller, allowing matching broadcast signals to routed to this client. In reality this is just a no-op giving the impression that the match was successfully registered. =cut sub add_match { my $self = shift; my $rule = shift; # XXX do we need to implement anything ? probably not # nada } =item $bus->remove_match($rule) Unregister a signal match rule with the bus controller, preventing further broadcast signals being routed to this client. In reality this is just a no-op giving the impression that the match was successfully unregistered. =cut sub remove_match { my $self = shift; my $rule = shift; # XXX do we need to implement anything ? probably not # nada } =item $con->register_object_path($path, \&handler) Registers a handler for messages whose path matches that specified in the C<$path> parameter. The supplied code reference will be invoked with two parameters, the connection object on which the message was received, and the message to be processed (an instance of the C class). =cut sub register_object_path { my $self = shift; my $path = shift; my $code = shift; $self->{objects}->{$path} = $code; } =item $con->register_fallback($path, \&handler) Registers a handler for messages whose path starts with the prefix specified in the C<$path> parameter. The supplied code reference will be invoked with two parameters, the connection object on which the message was received, and the message to be processed (an instance of the C class). =cut sub register_fallback { my $self = shift; my $path = shift; my $code = shift; $self->{objects}->{$path} = $code; $self->{objectTrees}->{$path} = $code; } =item $con->unregister_object_path($path) Unregisters the handler associated with the object path C<$path>. The handler would previously have been registered with the C or C methods. =cut sub unregister_object_path { my $self = shift; my $path = shift; delete $self->{objects}->{$path}; } sub _call_method { my $self = shift; my $msg = shift; if (exists $self->{objects}->{$msg->get_path}) { my $cb = $self->{objects}->{$msg->get_path}; &$cb($self, $msg); } else { foreach my $path (reverse sort { $a cmp $b } keys %{$self->{objectTrees}}) { if ((index $msg->get_path, $path) == 0) { my $cb = $self->{objects}->{$path}; &$cb($self, $msg); return; } } if ($msg->get_path eq "/org/freedesktop/DBus") { if ($msg->get_member eq "GetNameOwner") { my $reply = $self->make_method_return_message($msg); my $iter = $reply->iterator(1); $iter->append(":1.1"); $self->send($reply); } } } } =item my $msg = $con->make_error_message($replyto, $name, $description) Creates a new message, representing an error which occurred during the handling of the method call object passed in as the C<$replyto> parameter. The C<$name> parameter is the formal name of the error condition, while the C<$description> is a short piece of text giving more specific information on the error. =cut sub make_error_message { my $self = shift; my $replyto = shift; my $name = shift; my $description = shift; if (1) { return Net::DBus::Test::MockMessage->new_error(replyto => $replyto, error_name => $name, error_description => $description); } else { return Net::DBus::Binding::Message::Error->new(replyto => $replyto, name => $name, description => $description); } } =item my $call = $con->make_method_call_message( $service_name, $object_path, $interface, $method_name); Create a message representing a call on the object located at the path C<$object_path> within the client owning the well-known name given by C<$service_name>. The method to be invoked has the name C<$method_name> within the interface specified by the C<$interface> parameter. =cut sub make_method_call_message { my $self = shift; my $service_name = shift; my $object_path = shift; my $interface = shift; my $method_name = shift; if (1) { return Net::DBus::Test::MockMessage->new_method_call(destination => $service_name, path => $object_path, interface => $interface, member => $method_name); } else { return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name, object_path => $object_path, interface => $interface, method_name => $method_name); } } =item my $msg = $con->make_method_return_message($replyto) Create a message representing a reply to the method call message passed in the C<$replyto> parameter. =cut sub make_method_return_message { my $self = shift; my $replyto = shift; if (1) { return Net::DBus::Test::MockMessage->new_method_return(replyto => $replyto); } else { return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto); } } =item my $msg = $con->make_signal_message($object_path, $interface, $signal_name); Creates a new message, representing a signal [to be] emitted by the object located under the path given by the C<$object_path> parameter. The name of the signal is given by the C<$signal_name> parameter, and is scoped to the interface given by the C<$interface> parameter. =cut sub make_signal_message { my $self = shift; my $object_path = shift; my $interface = shift; my $signal_name = shift; if (1) { return Net::DBus::Test::MockMessage->new_signal(object_path => $object_path, interface => $interface, signal_name => $signal_name); } else { return Net::DBus::Binding::Message::Signal->new(object_path => $object_path, interface => $interface, signal_name => $signal_name); } } 1; =pod =back =head1 BUGS It doesn't completely replicate the API of L, merely enough to make the high level bindings work in a test scenario. =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2009 Daniel P. Berrange =head1 SEE ALSO L, L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Test/MockIterator.pm0000644000076500007650000005671511603165524021271 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Test::MockIterator - Iterator over a mock message =head1 SYNOPSIS Creating a new message my $msg = new Net::DBus::Test::MockMessage my $iterator = $msg->iterator; $iterator->append_boolean(1); $iterator->append_byte(123); Reading from a mesage my $msg = ...get it from somewhere... my $iter = $msg->iterator(); my $i = 0; while ($iter->has_next()) { $iter->next(); $i++; if ($i == 1) { my $val = $iter->get_boolean(); } elsif ($i == 2) { my $val = $iter->get_byte(); } } =head1 DESCRIPTION This module provides a "mock" counterpart to the L object which is capable of iterating over mock message objects. Instances of this module are not created directly, instead they are obtained via the C method on the L module. =head1 METHODS =over 4 =cut package Net::DBus::Test::MockIterator; use 5.006; use strict; use warnings; sub _new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; my %params = @_; $self->{data} = exists $params{data} ? $params{data} : die "data parameter is required"; $self->{append} = exists $params{append} ? $params{append} : 0; $self->{position} = 0; bless $self, $class; return $self; } =item $res = $iter->has_next() Determines if there are any more fields in the message itertor to be read. Returns a positive value if there are more fields, zero otherwise. =cut sub has_next { my $self = shift; if ($self->{position} < $#{$self->{data}}) { return 1; } return 0; } =item $success = $iter->next() Skips the iterator onto the next field in the message. Returns a positive value if the current field pointer was successfully advanced, zero otherwise. =cut sub next { my $self = shift; $self->{position}++; if ($self->{position} <= $#{$self->{data}}) { return 1; } return 0; } =item my $val = $iter->get_boolean() =item $iter->append_boolean($val); Read or write a boolean value from/to the message iterator =cut sub get_boolean { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_BOOLEAN); } sub append_boolean { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0] ? 1 : ""); } =item my $val = $iter->get_byte() =item $iter->append_byte($val); Read or write a single byte value from/to the message iterator. =cut sub get_byte { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_BYTE); } sub append_byte { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]); } =item my $val = $iter->get_string() =item $iter->append_string($val); Read or write a UTF-8 string value from/to the message iterator =cut sub get_string { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_STRING); } sub append_string { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]); } =item my $val = $iter->get_object_path() =item $iter->append_object_path($val); Read or write a UTF-8 string value, whose contents is a valid object path, from/to the message iterator =cut sub get_object_path { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH); } sub append_object_path { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]); } =item my $val = $iter->get_signature() =item $iter->append_signature($val); Read or write a UTF-8 string, whose contents is a valid type signature, value from/to the message iterator =cut sub get_signature { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_SIGNATURE); } sub append_signature { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]); } =item my $val = $iter->get_int16() =item $iter->append_int16($val); Read or write a signed 16 bit value from/to the message iterator =cut sub get_int16 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_INT16); } sub append_int16 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_INT16, int($_[0])); } =item my $val = $iter->get_uint16() =item $iter->append_uint16($val); Read or write an unsigned 16 bit value from/to the message iterator =cut sub get_uint16 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT16); } sub append_uint16 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_UINT16, int($_[0])); } =item my $val = $iter->get_int32() =item $iter->append_int32($val); Read or write a signed 32 bit value from/to the message iterator =cut sub get_int32 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_INT32); } sub append_int32 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_INT32, int($_[0])); } =item my $val = $iter->get_uint32() =item $iter->append_uint32($val); Read or write an unsigned 32 bit value from/to the message iterator =cut sub get_uint32 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT32); } sub append_uint32 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_UINT32, int($_[0])); } =item my $val = $iter->get_int64() =item $iter->append_int64($val); Read or write a signed 64 bit value from/to the message iterator. An error will be raised if this build of Perl does not support 64 bit integers =cut sub get_int64 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_INT64); } sub append_int64 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_INT64, int($_[0])); } =item my $val = $iter->get_uint64() =item $iter->append_uint64($val); Read or write an unsigned 64 bit value from/to the message iterator. An error will be raised if this build of Perl does not support 64 bit integers =cut sub get_uint64 { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT64); } sub append_uint64 { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_UINT64, int($_[0])); } =item my $val = $iter->get_double() =item $iter->append_double($val); Read or write a double precision floating point value from/to the message iterator =cut sub get_double { my $self = shift; return $self->_get(&Net::DBus::Binding::Message::TYPE_DOUBLE); } sub append_double { my $self = shift; $self->_append(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]); } =item my $value = $iter->get() =item my $value = $iter->get($type); Get the current value pointed to by this iterator. If the optional C<$type> parameter is supplied, the wire type will be compared with the desired type & a warning output if their differ. The C<$type> value must be one of the C constants. =cut sub get { my $self = shift; my $type = shift; if (defined $type) { if (ref($type)) { if (ref($type) eq "ARRAY") { # XXX we should recursively validate types $type = $type->[0]; if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $type = &Net::DBus::Binding::Message::TYPE_ARRAY; } } else { die "unsupport type reference $type"; } } my $actual = $self->get_arg_type; if ($actual != $type) { # "Be strict in what you send, be leniant in what you accept" # - ie can't rely on python to send correct types, eg int32 vs uint32 #die "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)"; warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)"; $type = $actual; } } else { $type = $self->get_arg_type; } if ($type == &Net::DBus::Binding::Message::TYPE_STRING) { return $self->get_string; } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { return $self->get_boolean; } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { return $self->get_byte; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { return $self->get_int16; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { return $self->get_uint16; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { return $self->get_int32; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { return $self->get_uint32; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { return $self->get_int64; } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { return $self->get_uint64; } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { return $self->get_double; } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) { my $array_type = $self->get_element_type(); if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { return $self->get_dict(); } else { return $self->get_array($array_type); } } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) { return $self->get_struct(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) { return $self->get_variant(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { die "dictionary can only occur as part of an array type"; } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) { die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID"; } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { return $self->get_object_path(); } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { return $self->get_signature(); } else { die "unknown argument type '" . chr($type) . "' ($type)"; } } =item my $hashref = $iter->get_dict() If the iterator currently points to a dictionary value, unmarshalls and returns the value as a hash reference. =cut sub get_dict { my $self = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $dict = {}; while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { my $entry = $iter->get_struct(); if ($#{$entry} != 1) { die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements"; } $dict->{$entry->[0]} = $entry->[1]; $iter->next(); $type = $iter->get_arg_type(); } return $dict; } =item my $hashref = $iter->get_array() If the iterator currently points to an array value, unmarshalls and returns the value as a array reference. =cut sub get_array { my $self = shift; my $array_type = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $array = []; while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { if ($type != $array_type) { die "Element $type not of array type $array_type"; } my $value = $iter->get($type); push @{$array}, $value; $iter->next(); $type = $iter->get_arg_type(); } return $array; } =item my $hashref = $iter->get_variant() If the iterator currently points to a variant value, unmarshalls and returns the value contained in the variant. =cut sub get_variant { my $self = shift; my $iter = $self->_recurse(); return $iter->get(); } =item my $hashref = $iter->get_struct() If the iterator currently points to an struct value, unmarshalls and returns the value as a array reference. The values in the array correspond to members of the struct. =cut sub get_struct { my $self = shift; my $iter = $self->_recurse(); my $type = $iter->get_arg_type(); my $struct = []; while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { my $value = $iter->get($type); push @{$struct}, $value; $iter->next(); $type = $iter->get_arg_type(); } return $struct; } =item $iter->append($value) =item $iter->append($value, $type) Appends a value to the message associated with this iterator. The value is marshalled into wire format, according to the following rules. If the C<$value> is an instance of L, the embedded data type is used. If the C<$type> parameter is supplied, that is taken to represent the data type. The type must be one of the C constants. Otherwise, the data type is chosen to be a string, dict or array according to the perl data types SCALAR, HASH or ARRAY. =cut sub append { my $self = shift; my $value = shift; my $type = shift; if (ref($value) eq "Net::DBus::Binding::Value" && ((! defined ref($type)) || (ref($type) ne "ARRAY") || $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) { $type = $value->type; $value = $value->value; } if (!defined $type) { $type = $self->guess_type($value); } if (ref($type) eq "ARRAY") { my $maintype = $type->[0]; my $subtype = $type->[1]; if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $self->append_dict($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { $self->append_struct($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { $self->append_array($value, $subtype); } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { $self->append_variant($value, $subtype); } else { die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')"; } } else { # XXX is this good idea or not $value = '' unless defined $value; if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { $self->append_boolean($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { $self->append_byte($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) { $self->append_string($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { $self->append_int16($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { $self->append_uint16($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { $self->append_int32($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { $self->append_uint32($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { $self->append_int64($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { $self->append_uint64($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { $self->append_double($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { $self->append_object_path($value); } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { $self->append_signature($value); } else { die "Unsupported scalar type ", $type, " ('", chr($type), "')"; } } } =item my $type = $iter->guess_type($value) Make a best guess at the on the wire data type to use for marshalling C<$value>. If the value is a hash reference, the dictionary type is returned; if the value is an array reference the array type is returned; otherwise the string type is returned. =cut sub guess_type { my $self = shift; my $value = shift; if (ref($value)) { if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { my $type = $value->type; if (ref($type) && ref($type) eq "ARRAY") { my $maintype = $type->[0]; my $subtype = $type->[1]; if (!defined $subtype) { if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $subtype = [ $self->guess_type(($value->value())[0]->[0]), $self->guess_type(($value->value())[0]->[1]) ]; } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { $subtype = [ $self->guess_type(($value->value())[0]->[0]) ]; } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ]; } else { die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n"; } } return [$maintype, $subtype]; } else { return $type; } } elsif (ref($value) eq "HASH") { my $key = (keys %{$value})[0]; my $val = $value->{$key}; # XXX Basically impossible to decide between DICT & STRUCT return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ]; } elsif (ref($value) eq "ARRAY") { return [ &Net::DBus::Binding::Message::TYPE_ARRAY, [$self->guess_type($value->[0])] ]; } else { die "cannot marshall reference of type " . ref($value); } } else { # XXX Should we bother trying to guess integer & floating point types ? # I say sod it, because strongly typed languages will support introspection # and loosely typed languages won't care about the difference return &Net::DBus::Binding::Message::TYPE_STRING; } } =item my $sig = $iter->format_signature($type) Given a data type representation, construct a corresponding signature string =cut sub format_signature { my $self = shift; my $type = shift; my ($sig, $t, $i); $sig = ""; $i = 0; if (ref($type) eq "ARRAY") { while ($i <= $#{$type}) { $t = $$type[$i]; if (ref($t) eq "ARRAY") { $sig .= $self->format_signature($t); } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY); $sig .= "{" . $self->format_signature($$type[++$i]) . "}"; } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) { $sig .= "(" . $self->format_signature($$type[++$i]) . ")"; } else { $sig .= chr($t); } $i++; } } else { $sig .= chr ($type); } return $sig; } =item $iter->append_array($value, $type) Append an array of values to the message. The C<$value> parameter must be an array reference, whose elements all have the same data type specified by the C<$type> parameter. =cut sub append_array { my $self = shift; my $array = shift; my $type = shift; if (!defined($type)) { $type = [$self->guess_type($array->[0])]; } die "array must only have one type" if $#{$type} > 0; my $sig = $self->format_signature($type); my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); foreach my $value (@{$array}) { $iter->append($value, $type->[0]); } } =item $iter->append_struct($value, $type) Append a struct to the message. The C<$value> parameter must be an array reference, whose elements correspond to members of the structure. The C<$type> parameter encodes the type of each member of the struct. =cut sub append_struct { my $self = shift; my $struct = shift; my $type = shift; if (defined($type) && $#{$struct} != $#{$type}) { die "number of values does not match type"; } my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, ""); my @type = defined $type ? @{$type} : (); foreach my $value (@{$struct}) { $iter->append($value, shift @type); } } =item $iter->append_dict($value, $type) Append a dictionary to the message. The C<$value> parameter must be an hash reference.The C<$type> parameter encodes the type of the key and value of the hash. =cut sub append_dict { my $self = shift; my $hash = shift; my $type = shift; my $sig; $sig = "{"; $sig .= $self->format_signature($type); $sig .= "}"; my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); foreach my $key (keys %{$hash}) { my $value = $hash->{$key}; my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, $sig); $entry->append($key, $type->[0]); $entry->append($value, $type->[1]); } } =item $iter->append_variant($value) Append a value to the message, encoded as a variant type. The C<$value> can be of any type, however, the variant will be encoded as either a string, dictionary or array according to the rules of the C method. =cut sub append_variant { my $self = shift; my $value = shift; my $type = shift; if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { $type = [$self->guess_type($value)]; $value = $value->value; } elsif (!defined $type || !defined $type->[0]) { $type = [$self->guess_type($value)]; } die "variant must only have one type" if defined $type && $#{$type} > 0; my $sig = $self->format_signature($type->[0]); my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig); $iter->append($value, $type->[0]); } =item my $type = $iter->get_arg_type Retrieves the type code of the value pointing to by this iterator. The returned code will correspond to one of the constants C =cut sub get_arg_type { my $self = shift; return &Net::DBus::Binding::Message::TYPE_INVALID if $self->{position} > $#{$self->{data}}; my $data = $self->{data}->[$self->{position}]; return $data->[0]; } =item my $type = $iter->get_element_type If the iterator points to an array, retrieves the type code of array elements. The returned code will correspond to one of the constants C =cut sub get_element_type { my $self = shift; die "current element is not valid" if $self->{position} > $#{$self->{data}}; my $data = $self->{data}->[$self->{position}]; if ($data->[0] != &Net::DBus::Binding::Message::TYPE_ARRAY) { die "current element is not an array"; } return $data->[1]->[0]->[0]; } sub _recurse { my $self = shift; die "_recurse call is not valid for writable iterator" if $self->{append}; die "current element is not valid" if $self->{position} > $#{$self->{data}}; my $data = $self->{data}->[$self->{position}]; my $type = $data->[0]; if ($type != &Net::DBus::Binding::Message::TYPE_STRUCT && $type != &Net::DBus::Binding::Message::TYPE_ARRAY && $type != &Net::DBus::Binding::Message::TYPE_DICT_ENTRY && $type != &Net::DBus::Binding::Message::TYPE_VARIANT) { die "current data element '$type' is not a container"; } return $self->_new(data => $data->[1], append => 0); } sub _append { my $self = shift; my $type = shift; my $data = shift; die "iterator is not open for append" unless $self->{append}; push @{$self->{data}}, [$type, $data]; } sub _open_container { my $self = shift; my $type = shift; my $sig = shift; my $data = []; push @{$self->{data}}, [$type, $data, $sig]; return $self->_new(data => $data, append => 1); } sub _get { my $self = shift; my $type = shift; die "iterator is not open for reading" if $self->{append}; die "current element is not valid" if $self->{position} > $#{$self->{data}}; my $data = $self->{data}->[$self->{position}]; die "data type does not match" unless $data->[0] == $type; return $data->[1]; } 1; =pod =back =head1 BUGS It doesn't completely replicate the API of L, merely enough to make the high level bindings work in a test scenario. =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2009 Daniel P. Berrange =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Test/MockMessage.pm0000644000076500007650000002404011603165524021046 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2005-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Test::MockMessage - Fake a message object when unit testing =head1 SYNOPSIS Sending a message my $msg = new Net::DBus::Test::MockMessage; my $iterator = $msg->iterator; $iterator->append_byte(132); $iterator->append_int32(14241); $connection->send($msg); =head1 DESCRIPTION This module provides a "mock" counterpart to the L class. It is basically a pure Perl fake message object providing the same contract as the real message object. It is intended for use internally by the testing APIs. =head1 METHODS =over 4 =cut package Net::DBus::Test::MockMessage; use 5.006; use strict; use warnings; use vars qw($SERIAL); BEGIN { $SERIAL = 1; } use Net::DBus::Binding::Message; use Net::DBus::Test::MockIterator; =item my $call = Net::DBus::Test::MockMessage->new_method_call( service_name => $service, object_path => $object, interface => $interface, method_name => $name); Create a message representing a call on the object located at the path C within the client owning the well-known name given by C. The method to be invoked has the name C within the interface specified by the C parameter. =cut sub new_method_call { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL, @_); bless $self, $class; return $self; } =item my $msg = Net::DBus::Test::MockMessage->new_method_return( replyto => $method_call); Create a message representing a reply to the method call passed in the C parameter. =cut sub new_method_return { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN, @_); bless $self, $class; return $self; } =item my $signal = Net::DBus::Test::MockMessage->new_signal( object_path => $path, interface => $interface, signal_name => $name); Creates a new message, representing a signal [to be] emitted by the object located under the path given by the C parameter. The name of the signal is given by the C parameter, and is scoped to the interface given by the C parameter. =cut sub new_signal { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL, @_); bless $self, $class; return $self; } =item my $msg = Net::DBus::Test::MockMessage->new_error( replyto => $method_call, name => $name, description => $description); Creates a new message, representing an error which occurred during the handling of the method call object passed in as the C parameter. The C parameter is the formal name of the error condition, while the C is a short piece of text giving more specific information on the error. =cut sub new_error { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR, @_); bless $self, $class; return $self; } sub _new { my $proto = shift; my $class = ref($proto) || $proto; my %params = @_; my $self = {}; $self->{type} = exists $params{type} ? $params{type} : die "type parameter is required"; $self->{interface} = exists $params{interface} ? $params{interface} : undef; $self->{path} = exists $params{path} ? $params{path} : undef; $self->{destination} = exists $params{destination} ? $params{destination} : undef; $self->{sender} = exists $params{sender} ? $params{sender} : undef; $self->{member} = exists $params{member} ? $params{member} : undef; $self->{error_name} = exists $params{error_name} ? $params{error_name} : undef; $self->{data} = []; $self->{no_reply} = 0; $self->{serial} = $SERIAL++; $self->{replyserial} = exists $params{replyto} ? $params{replyto}->get_serial : 0; bless $self, $class; if ($self->{type} == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { my $desc = exists $params{error_description} ? $params{error_description} : ""; my $iter = $self->iterator(1); $iter->append_string($desc); } return $self; } =item my $type = $msg->get_type Retrieves the type code for this message. The returned value corresponds to one of the four C constants. =cut sub get_type { my $self = shift; return $self->{type}; } =item my $name = $msg->get_error_name Returns the formal name of the error, as previously passed in via the C parameter in the constructor. =cut sub get_error_name { my $self = shift; return $self->{error_name}; } =item my $interface = $msg->get_interface Retrieves the name of the interface targetted by this message, possibly an empty string if there is no applicable interface for this message. =cut sub get_interface { my $self = shift; return $self->{interface}; } =item my $path = $msg->get_path Retrieves the object path associated with the message, possibly an empty string if there is no applicable object for this message. =cut sub get_path { my $self = shift; return $self->{path}; } =item my $name = $msg->get_destination Retrieves the uniqe or well-known bus name for client intended to be the recipient of the message. Possibly returns an empty string if the message is being broadcast to all clients. =cut sub get_destination { my $self = shift; return $self->{destination}; } =item my $name = $msg->get_sender Retireves the unique name of the client sending the message =cut sub get_sender { my $self = shift; return $self->{sender}; } =item my $serial = $msg->get_serial Retrieves the unique serial number of this message. The number is guarenteed unique for as long as the connection over which the message was sent remains open. May return zero, if the message is yet to be sent. =cut sub get_serial { my $self = shift; return $self->{serial}; } =item my $name = $msg->get_member For method calls, retrieves the name of the method to be invoked, while for signals, retrieves the name of the signal. =cut sub get_member { my $self = shift; return $self->{member}; } =item $msg->set_sender($name) Set the name of the client sending the message. The name must be the unique name of the client. =cut sub set_sender { my $self = shift; $self->{sender} = shift; } =item $msg->set_destination($name) Set the name of the intended recipient of the message. This is typically used for signals to switch them from broadcast to unicast. =cut sub set_destination { my $self = shift; $self->{destination} = shift; } =item my $iterator = $msg->iterator; Retrieves an iterator which can be used for reading or writing fields of the message. The returned object is an instance of the C class. =cut sub iterator { my $self = shift; my $append = @_ ? shift : 0; return Net::DBus::Test::MockIterator->_new(data => $self->{data}, append => $append); } =item $boolean = $msg->get_no_reply() Gets the flag indicating whether the message is expecting a reply to be sent. =cut sub get_no_reply { my $self = shift; return $self->{no_reply}; } =item $msg->set_no_reply($boolean) Toggles the flag indicating whether the message is expecting a reply to be sent. All method call messages expect a reply by default. By toggling this flag the communication latency is reduced by removing the need for the client to wait =cut sub set_no_reply { my $self = shift; $self->{no_reply} = shift; } =item my @values = $msg->get_args_list De-marshall all the values in the body of the message, using the message signature to identify data types. The values are returned as a list. =cut sub get_args_list { my $self = shift; my @ret; my $iter = $self->iterator; if ($iter->get_arg_type() != &Net::DBus::Binding::Message::TYPE_INVALID) { do { push @ret, $iter->get(); } while ($iter->next); } return @ret; } =item $msg->append_args_list(@values) Append a set of values to the body of the message. Values will be encoded as either a string, list or dictionary as appropriate to their Perl data type. For more specific data typing needs, the L object should be used instead. =cut sub append_args_list { my $self = shift; my @args = @_; my $iter = $self->iterator(1); foreach my $arg (@args) { $iter->append($arg); } } =item my $sig = $msg->get_signature Retrieves a string representing the type signature of the values packed into the body of the message. =cut sub get_signature { my $self = shift; my @bits = map { $self->_do_get_signature($_) } @{$self->{data}}; return join ("", @bits); } sub _do_get_signature { my $self = shift; my $element = shift; if ($element->[0] == &Net::DBus::Binding::Message::TYPE_ARRAY) { return chr(&Net::DBus::Binding::Message::TYPE_ARRAY) . $element->[2]; } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_STRUCT) { my @bits = map { $self->_do_get_signature($_) } @{$element->[1]}; return "{" . join("", @bits) . "}"; } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_VARIANT) { return chr(&Net::DBus::Binding::Message::TYPE_VARIANT); } else { return chr($element->[0]); } } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2009 Daniel P. Berrange =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Test/MockObject.pm0000644000076500007650000001765411603165524020705 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Test::MockObject - Fake an object from the bus for unit testing =head1 SYNOPSIS use Net::DBus; use Net::DBus::Test::MockObject; my $bus = Net::DBus->test # Lets fake presence of HAL... # First we need to define the service my $service = $bus->export_service("org.freedesktop.Hal"); # Then create a mock object my $object = Net::DBus::Test::MockObject->new($service, "/org/freedesktop/Hal/Manager"); # Fake the 'GetAllDevices' method $object->seed_action("org.freedesktop.Hal.Manager", "GetAllDevices", reply => { return => [ "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port", "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port_logicaldev_input", "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port", "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port_logicaldev_input" ], }); # Now can test any class which calls out to 'GetAllDevices' in HAL ....test stuff.... =head1 DESCRIPTION This provides an alternate for L to enable bus objects to be quickly mocked up, thus facilitating creation of unit tests for services which may need to call out to objects provided by 3rd party services on the bus. It is typically used as a companion to the L object, to enable complex services to be tested without actually starting a real bus. !!!!! WARNING !!! This object & its APIs should be considered very experimental at this point in time, and no guarentees about future API compatability are provided what-so-ever. Comments & suggestions on how to evolve this framework are, however, welcome & encouraged. =head1 METHODS =over 4 =cut package Net::DBus::Test::MockObject; use strict; use warnings; =item my $object = Net::DBus::Test::MockObject->new($service, $path, $interface); Create a new mock object, attaching to the service defined by the C<$service> parameter. This would be an instance of the L object. The C<$path> parameter defines the object path at which to attach this mock object, and C<$interface> defines the interface it will support. =cut sub new { my $class = shift; my $self = {}; $self->{service} = shift; $self->{object_path} = shift; $self->{interface} = shift; $self->{actions} = {}; $self->{message} = shift; bless $self, $class; $self->get_service->_register_object($self); return $self; } sub _get_sub_nodes { my $self = shift; return []; } =item my $service = $object->get_service Retrieves the L object within which this object is exported. =cut sub get_service { my $self = shift; return $self->{service}; } =item my $path = $object->get_object_path Retrieves the path under which this object is exported =cut sub get_object_path { my $self = shift; return $self->{object_path}; } =item my $msg = $object->get_last_message Retrieves the last message processed by this object. The returned object is an instance of L =cut sub get_last_message { my $self = shift; return $self->{message}; } =item my $sig = $object->get_last_message_signature Retrieves the type signature of the last processed message. =cut sub get_last_message_signature { my $self = shift; return $self->{message}->get_signature; } =item my $value = $object->get_last_message_param Returns the first value supplied as an argument to the last processed message. =cut sub get_last_message_param { my $self = shift; my @args = $self->{message}->get_args_list; return $args[0]; } =item my @values = $object->get_last_message_param_list Returns a list of all the values supplied as arguments to the last processed message. =cut sub get_last_message_param_list { my $self = shift; my @args = $self->{message}->get_args_list; return \@args; } =item $object->seed_action($interface, $method, %action); Registers an action to be performed when a message corresponding to the method C<$method> within the interface C<$interface> is received. The C<%action> parameter can have a number of possible keys set: =over 4 =item signals Causes a signal to be emitted when the method is invoked. The value associated with this key should be an instance of the L class. =item error Causes an error to be generated when the method is invoked. The value associated with this key should be a hash reference, with two elements. The first, C, giving the error name, and the second, C, providing the descriptive text. =item reply Causes a normal method return to be generated. The value associated with this key should be an array reference, whose elements are the values to be returned by the method. =back =cut sub seed_action { my $self = shift; my $interface = shift; my $method = shift; my %action = @_; $self->{actions}->{$method} = {} unless exists $self->{actions}->{$method}; $self->{actions}->{$method}->{$interface} = \%action; } sub _dispatch { my $self = shift; my $connection = shift; my $message = shift; my $interface = $message->get_interface; my $method = $message->get_member; my $con = $self->get_service->get_bus->get_connection; if (!exists $self->{actions}->{$method}) { my $error = $con->make_error_message($message, "org.freedesktop.DBus.Failed", "no action seeded for method " . $message->get_member); $con->send($error); return; } my $action; if ($interface) { if (!exists $self->{actions}->{$method}->{$interface}) { my $error = $con->make_error_message($message, "org.freedesktop.DBus.Failed", "no action with correct interface seeded for method " . $message->get_member); $con->send($error); return; } $action = $self->{actions}->{$method}->{$interface}; } else { my @interfaces = keys %{$self->{actions}->{$method}}; if ($#interfaces > 0) { my $error = $con->make_error_message($message, "org.freedesktop.DBus.Failed", "too many actions seeded for method " . $message->get_member); $con->send($error); return; } $action = $self->{actions}->{$method}->{$interfaces[0]}; } if (exists $action->{signals}) { my $sigs = $action->{signals}; if (ref($sigs) ne "ARRAY") { $sigs = [ $sigs ]; } foreach my $sig (@{$sigs}) { $self->get_service->get_bus->get_connection->send($sig); } } $self->{message} = $message; if (exists $action->{error}) { my $error = $con->make_error_message($message, $action->{error}->{name}, $action->{error}->{description}); $con->send($error); } elsif (exists $action->{reply}) { my $reply = $con->make_method_return_message($message); my $iter = $reply->iterator(1); foreach my $value (@{$action->{reply}->{return}}) { $iter->append($value); } $con->send($reply); } } 1; =pod =back =head1 BUGS It doesn't completely replicate the API of L, merely enough to make the high level bindings work in a test scenario. =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2004-2009 Daniel P. Berrange =head1 SEE ALSO L, L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Error.pm0000644000076500007650000000725111603165524017027 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Error - Error details for remote method invocation =head1 SYNOPSIS package Music::Player::UnknownFormat; use base qw(Net::DBus::Error); # Define an error type for unknown track encoding type # for a music player service sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->SUPER::new(name => "org.example.music.UnknownFormat", message => "Unknown track encoding format"); } package Music::Player::Engine; ...snip... # Play either mp3 or ogg music tracks, otherwise # thrown an error sub play { my $self = shift; my $url = shift; if ($url =~ /\.(mp3|ogg)$/) { ...play the track } else { die Music::Player::UnknownFormat->new(); } } =head1 DESCRIPTION This objects provides for strongly typed error handling. Normally a service would simply call die "some message text" When returning the error condition to the calling DBus client, the message is associated with a generic error code or "org.freedesktop.DBus.Failed". While this suffices for many applications, occasionally it is desirable to be able to catch and handle specific error conditions. For such scenarios the service should create subclasses of the C object providing in a custom error name. This error name is then sent back to the client instead of the genreic "org.freedesktop.DBus.Failed" code. =head1 METHODS =over 4 =cut package Net::DBus::Error; use strict; use warnings; use overload ('""' => 'stringify'); =item my $error = Net::DBus::Error->new(name => $error_name, message => $description); Creates a new error object whose name is given by the C parameter, and long descriptive text is provided by the C parameter. The C parameter has certain formatting rules which must be adhered to. It must only contain the letters 'a'-'Z', '0'-'9', '-', '_' and '.'. There must be at least two components separated by a '.', For example a valid name is 'org.example.Music.UnknownFormat'. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; my %params = @_; $self->{name} = $params{name} ? $params{name} : die "name parameter is required"; $self->{message} = $params{message} ? $params{message} : die "message parameter is required"; bless $self, $class; return $self; } =item $error->name Returns the DBus error name associated with the object. =cut sub name { my $self = shift; return $self->{name}; } =item $error->message Returns the descriptive text/message associated with the error condition. =cut sub message { my $self = shift; return $self->{message}; } =item $error->stringify Formats the error as a string in a manner suitable for printing out / logging / displaying to the user, etc. =cut sub stringify { my $self = shift; return $self->{name} . ": " . $self->{message} . ($self->{message} =~ /\n$/ ? "" : "\n"); } 1; =pod =back =head1 AUTHOR Daniel P. Berrange =head1 COPYRIGHT Copyright (C) 2005-2011 Daniel P. Berrange =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/Annotation.pm0000644000076500007650000000531511603165524020047 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2006-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::Annotation - annotations for changing behaviour of APIs =head1 SYNOPSIS use Net::DBus::Annotation qw(:call); my $object = $service->get_object("/org/example/systemMonitor"); # Block until processes are listed my $processes = $object->list_processes("someuser"); # Just throw away list of processes, pretty pointless # in this example, but useful if the method doesn't have # a return value $object->list_processes(dbus_call_noreply, "someuser"); # List processes & get on with other work until # the list is returned. my $asyncreply = $object->list_processes(dbus_call_async, "someuser"); ... some time later... my $processes = $asyncreply->get_data; =head1 DESCRIPTION This module provides a number of annotations which will be useful when dealing with the DBus APIs. There are annotations for switching remote calls between sync, async and no-reply mode. More annotations may be added over time. =head1 METHODS =over 4 =cut package Net::DBus::Annotation; use strict; use warnings; our $CALL_SYNC = "sync"; our $CALL_ASYNC = "async"; our $CALL_NOREPLY = "noreply"; bless \$CALL_SYNC, __PACKAGE__; bless \$CALL_ASYNC, __PACKAGE__; bless \$CALL_NOREPLY, __PACKAGE__; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(dbus_call_sync dbus_call_async dbus_call_noreply); our %EXPORT_TAGS = (call => [qw(dbus_call_sync dbus_call_async dbus_call_noreply)]); =item dbus_call_sync Requests that a method call be performed synchronously, waiting for the reply or error return to be received before continuing. =cut sub dbus_call_sync() { return \$CALL_SYNC; } =item dbus_call_async Requests that a method call be performed a-synchronously, returning a pending call object, which will collect the reply when it eventually arrives. =cut sub dbus_call_async() { return \$CALL_ASYNC; } =item dbus_call_noreply Requests that a method call be performed a-synchronously, discarding any possible reply or error message. =cut sub dbus_call_noreply() { return \$CALL_NOREPLY; } 1; =pod =back =head1 AUTHOR Daniel Berrange =head1 COPYRIGHT Copright (C) 2006-2011, Daniel Berrange. =head1 SEE ALSO L, L =cut Net-DBus-1.0.0/lib/Net/DBus/ASyncReply.pm0000644000076500007650000001017011603165524017761 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2006-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus::ASyncReply - asynchronous method reply handler =head1 SYNOPSIS use Net::DBus::Annotation qw(:call); my $object = $service->get_object("/org/example/systemMonitor"); # List processes & get on with other work until # the list is returned. my $asyncreply = $object->list_processes(dbus_call_async, "someuser"); while (!$asyncreply->is_ready) { ... do some background work.. } my $processes = $asyncreply->get_result; =head1 DESCRIPTION This object provides a handler for receiving asynchronous method replies. An asynchronous reply object is generated when making remote method call with the C annotation set. =head1 METHODS =over 4 =cut package Net::DBus::ASyncReply; use strict; use warnings; sub _new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; my %params = @_; $self->{pending_call} = $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required"; $self->{introspector} = $params{introspector} ? $params{introspector} : undef; $self->{method_name} = $params{method_name} ? $params{method_name} : ($self->{introspector} ? die "method_name is parameter required for introspection" : undef); bless $self, $class; return $self; } =item $asyncreply->discard_result; Indicates that the caller is no longer interested in recieving the reply & that it should be discarded. After calling this method, this object should not be used again. =cut sub discard_result { my $self = shift; $self->{pending_call}->cancel; } =item $asyncreply->wait_for_result; Blocks the caller waiting for completion of the of the asynchronous reply. Upon returning from this method, the result can be obtained with the C method. =cut sub wait_for_result { my $self = shift; $self->{pending_call}->block; } =item my $boolean = $asyncreply->is_ready; Returns a true value if the asynchronous reply is now complete (or a timeout has occurred). When this method returns true, the result can be obtained with the C method. =cut sub is_ready { my $self = shift; return $self->{pending_call}->get_completed; } =item $asyncreply->set_notify($coderef); Sets a notify function which will be invoked when the asynchronous reply finally completes. The callback will be invoked with a single parameter which is this object. =cut sub set_notify { my $self = shift; my $cb = shift; $self->{pending_call}->set_notify(sub { my $pending_call = shift; &$cb($self); }); } =item my @data = $asyncreply->get_result; Retrieves the data associated with the asynchronous reply. If a timeout occurred, then this method will throw an exception. This method can only be called once the reply is complete, as indicated by the C method returning a true value. After calling this method, this object should no longer be used. =cut sub get_result { my $self = shift; my $reply = $self->{pending_call}->get_reply; if ($reply->isa("Net::DBus::Binding::Message::Error")) { my $iter = $reply->iterator(); my $desc = $iter->get_string(); die Net::DBus::Error->new(name => $reply->get_error_name, message => $desc); } my @reply; if ($self->{introspector}) { @reply = $self->{introspector}->decode($reply, "methods", $self->{method_name}, "returns"); } else { @reply = $reply->get_args_list; } return wantarray ? @reply : $reply[0]; } 1; =pod =back =head1 AUTHOR Daniel Berrange =head1 COPYRIGHT Copright (C) 2006-2011, Daniel Berrange. =head1 SEE ALSO L, L, L =cut Net-DBus-1.0.0/lib/Net/DBus.pm0000644000076500007650000004263411603165524015742 0ustar berrangeberrange# -*- perl -*- # # Copyright (C) 2004-2011 Daniel P. Berrange # # This program is free software; You can redistribute it and/or modify # it under the same terms as Perl itself. Either: # # a) the GNU General Public License as published by the Free # Software Foundation; either version 2, or (at your option) any # later version, # # or # # b) the "Artistic License" # # The file "COPYING" distributed along with this file provides full # details of the terms and conditions of the two licenses. =pod =head1 NAME Net::DBus - Perl extension for the DBus message system =head1 SYNOPSIS ####### Attaching to the bus ########### use Net::DBus; # Find the most appropriate bus my $bus = Net::DBus->find; # ... or explicitly go for the session bus my $bus = Net::DBus->session; # .... or explicitly go for the system bus my $bus = Net::DBus->system ######## Accessing remote services ######### # Get a handle to the HAL service my $hal = $bus->get_service("org.freedesktop.Hal"); # Get the device manager my $manager = $hal->get_object("/org/freedesktop/Hal/Manager", "org.freedesktop.Hal.Manager"); # List devices foreach my $dev (@{$manager->GetAllDevices}) { print $dev, "\n"; } ######### Providing services ############## # Register a service known as 'org.example.Jukebox' my $service = $bus->export_service("org.example.Jukebox"); =head1 DESCRIPTION Net::DBus provides a Perl API for the DBus message system. The DBus Perl interface is currently operating against the 0.32 development version of DBus, but should work with later versions too, providing the API changes have not been too drastic. Users of this package are either typically, service providers in which case the L and L modules are of most relevance, or are client consumers, in which case L and L are of most relevance. =head1 METHODS =over 4 =cut package Net::DBus; use 5.006; use strict; use warnings; BEGIN { our $VERSION = '1.0.0'; require XSLoader; XSLoader::load('Net::DBus', $VERSION); } use Net::DBus::Binding::Bus; use Net::DBus::Service; use Net::DBus::RemoteService; use Net::DBus::Test::MockConnection; use Net::DBus::Binding::Value; use vars qw($bus_system $bus_session); use Exporter qw(import); use vars qw(@EXPORT_OK %EXPORT_TAGS); @EXPORT_OK = qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64 dbus_byte dbus_boolean dbus_string dbus_double dbus_object_path dbus_signature dbus_struct dbus_array dbus_dict dbus_variant); %EXPORT_TAGS = (typing => [qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64 dbus_byte dbus_boolean dbus_string dbus_double dbus_object_path dbus_signature dbus_struct dbus_array dbus_dict dbus_variant)]); =item my $bus = Net::DBus->find(%params); Search for the most appropriate bus to connect to and return a connection to it. The heuristic used for the search is - If DBUS_STARTER_BUS_TYPE is set to 'session' attach to the session bus - Else If DBUS_STARTER_BUS_TYPE is set to 'system' attach to the system bus - Else If DBUS_SESSION_BUS_ADDRESS is set attach to the session bus - Else attach to the system bus The optional C hash can contain be used to specify connection options. The only support option at this time is C which prevents the bus from being automatically attached to the main L event loop. =cut sub find { my $class = shift; if ($ENV{DBUS_STARTER_BUS_TYPE} && $ENV{DBUS_STARTER_BUS_TYPE} eq "session") { return $class->session(@_); } elsif ($ENV{DBUS_STARTER_BUS_TYPE} && $ENV{DBUS_STARTER_BUS_TYPE} eq "system") { return $class->system(@_); } elsif (exists $ENV{DBUS_SESSION_BUS_ADDRESS}) { return $class->session(@_); } else { return $class->system; } } =item my $bus = Net::DBus->system(%params); Return a handle for the system message bus. Note that the system message bus is locked down by default, so unless appropriate access control rules are added in /etc/dbus/system.d/, an application may access services, but won't be able to export services. The optional C hash can contain be used to specify connection options. The only support option at this time is C which prevents the bus from being automatically attached to the main L event loop. =cut sub system { my $class = shift; my %params = @_; if ($params{private}) { return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM, private => 1), @_); } unless ($bus_system) { $bus_system = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM), @_); } return $bus_system } =item my $bus = Net::DBus->session(%params); Return a handle for the session message bus. The optional C hash can contain be used to specify connection options. The only support option at this time is C which prevents the bus from being automatically attached to the main L event loop. =cut sub session { my $class = shift; my %params = @_; if ($params{private}) { return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION, private => 1), @_); } unless ($bus_session) { $bus_session = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION), @_); } return $bus_session; } =item my $bus = Net::DBus->test(%params); Returns a handle for a virtual bus for use in unit tests. This bus does not make any network connections, but rather has an in-memory message pipeline. Consult L for further details of how to use this special bus. =cut # NB. explicitly do *NOT* cache, since unit tests # should always have pristine state sub test { my $class = shift; return $class->_new(Net::DBus::Test::MockConnection->new()); } =item my $bus = Net::DBus->new($address, %params); Return a connection to a specific message bus. The C<$address> parameter must contain the address of the message bus to connect to. An example address for a session bus might look like C, while one for a system bus would look like C. The optional C hash can contain be used to specify connection options. The only support option at this time is C which prevents the bus from being automatically attached to the main L event loop. =cut sub new { my $class = shift; my $nomainloop = shift; return $class->_new(Net::DBus::Binding::Bus->new(address => shift), @_); } sub _new { my $class = shift; my $self = {}; $self->{connection} = shift; $self->{signals} = []; # Map well known names to RemoteService objects $self->{services} = {}; my %params = @_; bless $self, $class; unless ($params{nomainloop}) { if (exists $INC{'Net/DBus/Reactor.pm'}) { my $reactor = $params{reactor} ? $params{reactor} : Net::DBus::Reactor->main; $reactor->manage($self->get_connection); } # ... Add support for GLib and POE } $self->get_connection->add_filter(sub { return $self->_signal_func(@_); }); $self->{bus} = $self->{services}->{"org.freedesktop.DBus"} = Net::DBus::RemoteService->new($self, "org.freedesktop.DBus", "org.freedesktop.DBus"); $self->get_bus_object()->connect_to_signal('NameOwnerChanged', sub { my ($svc, $old, $new) = @_; # Slightly evil poking into the private 'owner_name' field here if (exists $self->{services}->{$svc}) { $self->{services}->{$svc}->{owner_name} = $new; } }); return $self; } =item my $connection = $bus->get_connection; Return a handle to the underlying, low level connection object associated with this bus. The returned object will be an instance of the L class. This method is not intended for use by (most!) application developers, so if you don't understand what this is for, then you don't need to be calling it! =cut sub get_connection { my $self = shift; return $self->{connection}; } =item my $service = $bus->get_service($name); Retrieves a handle for the remote service identified by the service name C<$name>. The returned object will be an instance of the L class. =cut sub get_service { my $self = shift; my $name = shift; if ($name eq "org.freedesktop.DBus") { return $self->{bus}; } if (!exists $self->{services}->{$name}) { my $owner = $name; if ($owner !~ /^:/) { $owner = $self->get_service_owner($name); if (!defined $owner) { $self->get_bus_object->StartServiceByName($name, 0); $owner = $self->get_service_owner($name); } } $self->{services}->{$name} = Net::DBus::RemoteService->new($self, $owner, $name); } return $self->{services}->{$name}; } =item my $service = $bus->export_service($name); Registers a service with the bus, returning a handle to the service. The returned object is an instance of the L class. =cut sub export_service { my $self = shift; my $name = shift; return Net::DBus::Service->new($self, $name); } =item my $object = $bus->get_bus_object; Retrieves a handle to the bus object, C, provided by the service C. The returned object is an instance of L =cut sub get_bus_object { my $self = shift; my $service = $self->get_service("org.freedesktop.DBus"); return $service->get_object('/org/freedesktop/DBus', 'org.freedesktop.DBus'); } =item my $name = $bus->get_unique_name; Retrieves the unique name of this client's connection to the bus. =cut sub get_unique_name { my $self = shift; return $self->get_connection->get_unique_name } =item my $name = $bus->get_service_owner($service); Retrieves the unique name of the client on the bus owning the service named by the C<$service> parameter. =cut sub get_service_owner { my $self = shift; my $service = shift; my $bus = $self->get_bus_object; my $owner = eval { $bus->GetNameOwner($service); }; if ($@) { if (UNIVERSAL::isa($@, "Net::DBus::Error") && $@->{name} eq "org.freedesktop.DBus.Error.NameHasNoOwner") { $owner = undef; } else { die $@; } } return $owner; } sub _add_signal_receiver { my $self = shift; my $receiver = shift; my $signal_name = shift; my $interface = shift; my $service = shift; my $path = shift; my $rule = $self->_match_rule($signal_name, $interface, $service, $path); push @{$self->{signals}}, { cb => $receiver, rule => $rule, signal_name => $signal_name, interface => $interface, service => $service, path => $path }; $self->{connection}->add_match($rule); } sub _remove_signal_receiver { my $self = shift; my $receiver = shift; my $signal_name = shift; my $interface = shift; my $service = shift; my $path = shift; my $rule = $self->_match_rule($signal_name, $interface, $service, $path); my @signals; foreach (@{$self->{signals}}) { if ($_->{cb} eq $receiver && $_->{rule} eq $rule) { $self->{connection}->remove_match($rule); } else { push @signals, $_; } } $self->{signals} = \@signals; } sub _match_rule { my $self = shift; my $signal_name = shift; my $interface = shift; my $service = shift; my $path = shift; my $rule = "type='signal'"; if (defined $interface) { $rule .= ",interface='$interface'"; } if (defined $path) { $rule .= ",path='$path'"; } if (defined $service) { $rule .= ",sender='$service'"; } if (defined $signal_name) { $rule .= ",member='$signal_name'"; } return $rule; } sub _handler_matches { my $self = shift; my $handler = shift; my $signal_name = shift; my $interface = shift; my $sender = shift; my $path = shift; if (defined $handler->{signal_name} && $handler->{signal_name} ne $signal_name) { return 0; } if (defined $handler->{interface} && $handler->{interface} ne $interface) { return 0; } if (defined $handler->{path} && $handler->{path} ne $path) { return 0; } if (defined $handler->{service}) { my $owner = $self->{services}->{$handler->{service}}; return 0 unless defined $owner; return 0 unless $owner->get_owner_name eq $sender; } return 1; } sub _signal_func { my $self = shift; my $connection = shift; my $message = shift; return 0 unless $message->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL; my $interface = $message->get_interface; my $sender = $message->get_sender; my $path = $message->get_path; my $signal_name = $message->get_member; my $handled = 0; foreach my $handler (@{$self->{signals}}) { next unless $self->_handler_matches($handler, $signal_name, $interface, $sender, $path); my $callback = $handler->{cb}; &$callback($message); $handled = 1; } return $handled; } =back =head1 DATA TYPING METHODS These methods are not usually used, since most services provide introspection data to inform clients of their data typing requirements. If introspection data is incomplete, however, it may be necessary for a client to mark values with specific data types. In such a case, the following methods can be used. They are not, however, exported by default so must be requested at import time by specifying 'use Net::DBus qw(:typing)' =over 4 =item $typed_value = dbus_int16($value); Mark a value as being a signed, 16-bit integer. =cut sub dbus_int16 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT16, $_[0]); } =item $typed_value = dbus_uint16($value); Mark a value as being an unsigned, 16-bit integer. =cut sub dbus_uint16 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT16, $_[0]); } =item $typed_value = dbus_int32($value); Mark a value as being a signed, 32-bit integer. =cut sub dbus_int32 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT32, $_[0]); } =item $typed_value = dbus_uint32($value); Mark a value as being an unsigned, 32-bit integer. =cut sub dbus_uint32 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT32, $_[0]); } =item $typed_value = dbus_int64($value); Mark a value as being an unsigned, 64-bit integer. =cut sub dbus_int64 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT64, $_[0]); } =item $typed_value = dbus_uint64($value); Mark a value as being an unsigned, 64-bit integer. =cut sub dbus_uint64 { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT64, $_[0]); } =item $typed_value = dbus_double($value); Mark a value as being a double precision IEEE floating point. =cut sub dbus_double { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]); } =item $typed_value = dbus_byte($value); Mark a value as being an unsigned, byte. =cut sub dbus_byte { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]); } =item $typed_value = dbus_string($value); Mark a value as being a UTF-8 string. This is not usually required since 'string' is the default data type for any Perl scalar value. =cut sub dbus_string { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]); } =item $typed_value = dbus_signature($value); Mark a value as being a UTF-8 string, whose contents is a valid type signature =cut sub dbus_signature { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]); } =item $typed_value = dbus_object_path($value); Mark a value as being a UTF-8 string, whose contents is a valid object path. =cut sub dbus_object_path { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]); } =item $typed_value = dbus_boolean($value); Mark a value as being an boolean =cut sub dbus_boolean { return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0]); } =item $typed_value = dbus_array($value); Mark a value as being an array =cut sub dbus_array { return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_ARRAY], $_[0]); } =item $typed_value = dbus_struct($value); Mark a value as being a structure =cut sub dbus_struct { return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_STRUCT], $_[0]); } =item $typed_value = dbus_dict($value); Mark a value as being a dictionary =cut sub dbus_dict{ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_DICT_ENTRY], $_[0]); } =item $typed_value = dbus_variant($value); Mark a value as being a variant =cut sub dbus_variant{ return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_VARIANT], $_[0]); } =pod =back =head1 SEE ALSO L, L, L, L, L, L, L, L, C, C, C, L, =head1 AUTHOR Daniel Berrange =head1 COPYRIGHT Copyright 2004-2011 by Daniel Berrange =cut 1; Net-DBus-1.0.0/MANIFEST0000644000076500007650000000362211603165543014377 0ustar berrangeberrangeAUTHORS autobuild.sh CHANGES DBus.xs examples/dump-object-xml.pl examples/dump-object.pl examples/example-client-async.pl examples/example-client-no-introspect.pl examples/example-client.pl examples/example-service-async.pl examples/example-service-magic.pl examples/example-service-no-introspect.pl examples/example-service.pl examples/example-signal-emitter.pl examples/example-signal-receiver.pl examples/lshal.pl examples/notification.pl examples/strict-exports.pl lib/Net/DBus.pm lib/Net/DBus/Annotation.pm lib/Net/DBus/ASyncReply.pm lib/Net/DBus/Binding/Bus.pm lib/Net/DBus/Binding/Connection.pm lib/Net/DBus/Binding/Introspector.pm lib/Net/DBus/Binding/Iterator.pm lib/Net/DBus/Binding/Message.pm lib/Net/DBus/Binding/Message/Error.pm lib/Net/DBus/Binding/Message/MethodCall.pm lib/Net/DBus/Binding/Message/MethodReturn.pm lib/Net/DBus/Binding/Message/Signal.pm lib/Net/DBus/Binding/PendingCall.pm lib/Net/DBus/Binding/Server.pm lib/Net/DBus/Binding/Value.pm lib/Net/DBus/Binding/Watch.pm lib/Net/DBus/Callback.pm lib/Net/DBus/Dumper.pm lib/Net/DBus/Error.pm lib/Net/DBus/Exporter.pm lib/Net/DBus/Object.pm lib/Net/DBus/Reactor.pm lib/Net/DBus/RemoteObject.pm lib/Net/DBus/RemoteService.pm lib/Net/DBus/Service.pm lib/Net/DBus/Test/MockConnection.pm lib/Net/DBus/Test/MockIterator.pm lib/Net/DBus/Test/MockMessage.pm lib/Net/DBus/Test/MockObject.pm lib/Net/DBus/Tutorial.pod lib/Net/DBus/Tutorial/ExportingObjects.pod lib/Net/DBus/Tutorial/UsingObjects.pod LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml META.yml.PL Net-DBus.spec Net-DBus.spec.PL README t/00-constants.t t/05-pod.t t/10-pod-coverage.t t/15-message.t t/20-callback.t t/25-reactor.t t/30-server.t t/40-introspector.t t/42-object-introspect-avahi.t t/45-exporter.t t/50-object-introspect.t t/55-method-calls.t t/56-scalar-param-typing.t t/60-object-props.t t/65-object-magic.t t/66-child-objects.t t/70-errors.t t/75-notifications.t typemap Net-DBus-1.0.0/typemap0000644000076500007650000000620711603165524014651 0ustar berrangeberrangeTYPEMAP const char * T_PV DBusConnection* O_OBJECT_connection DBusServer* O_OBJECT_server DBusMessage* O_OBJECT_message DBusPendingCall* O_OBJECT_pendingcall DBusWatch* O_OBJECT_watch DBusTimeout* O_OBJECT_timeout DBusMessageIter* O_OBJECT_messageiter DBusBusType T_IV dbus_bool_t T_BOOL dbus_int16_t T_IV dbus_uint16_t T_UV dbus_int32_t T_IV dbus_uint32_t T_UV dbus_int64_t T_DBUS_INT64 dbus_uint64_t T_DBUS_UINT64 INPUT T_DBUS_INT64 $var = _dbus_parse_int64($arg); OUTPUT T_DBUS_INT64 $arg = _dbus_format_int64($var); INPUT T_DBUS_UINT64 $var = _dbus_parse_uint64($arg); OUTPUT T_DBUS_UINT64 $arg = _dbus_format_uint64($var); INPUT O_OBJECT_connection if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_connection sv_setref_pv( $arg, "Net::DBus::Binding::C::Connection", (void*)$var ); INPUT O_OBJECT_server if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_server sv_setref_pv( $arg, "Net::DBus::Binding::C::Server", (void*)$var ); INPUT O_OBJECT_message if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_message sv_setref_pv( $arg, "Net::DBus::Binding::C::Message", (void*)$var ); INPUT O_OBJECT_pendingcall if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_pendingcall sv_setref_pv( $arg, "Net::DBus::Binding::C::PendingCall", (void*)$var ); INPUT O_OBJECT_watch if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_watch sv_setref_pv( $arg, "Net::DBus::Binding::C::Watch", (void*)$var ); INPUT O_OBJECT_timeout if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_timeout sv_setref_pv( $arg, "Net::DBus::Binding::C::Timeout", (void*)$var ); INPUT O_OBJECT_messageiter if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) $var = ($type)SvIV((SV*)SvRV( $arg )); else { warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } OUTPUT O_OBJECT_messageiter sv_setref_pv( $arg, "Net::DBus::Binding::Iterator", (void*)$var );