[libnet-dbus-perl] 155/335: Support annotations when exporting objects
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:45 UTC 2015
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.
commit d1b2e246e6296d0eda9d14cda6f8a4f0e4528169
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Nov 21 11:37:56 2005 +0000
Support annotations when exporting objects
---
lib/Net/DBus/Exporter.pm | 167 +++++++++++++++++++++++++++++++----------------
1 file changed, 110 insertions(+), 57 deletions(-)
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index f7c6911..c1721f7 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -16,7 +16,7 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
-# $Id: Exporter.pm,v 1.7 2005/10/15 13:31:42 dan Exp $
+# $Id: Exporter.pm,v 1.8 2005/11/21 11:37:56 dan Exp $
=pod
@@ -191,14 +191,38 @@ increments on every method call.
=back
-=head1 METHODS
+=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 dbus_method($name, $params, $returns);
+=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.
+
+=back
+
+=head1 METHODS
-=item dbus_method($name, $params, $returns, $interface);
+=over 4
+
+=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
@@ -277,6 +301,20 @@ returns a dictionary containing the last modification times.
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 });
+
=back
=head1 SEE ALSO
@@ -294,9 +332,9 @@ package Net::DBus::Exporter;
use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors);
use warnings;
-#use strict;
+use strict;
-require Exporter;
+use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(dbus_method dbus_signal dbus_property);
@@ -341,6 +379,7 @@ sub dbus_introspector {
# 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) {
@@ -375,21 +414,21 @@ sub _dbus_introspector_add {
my $exports = $dbus_exports{$class};
if ($exports) {
foreach my $method (keys %{$exports->{methods}}) {
- my ($params, $returns, $interface) = @{$exports->{methods}->{$method}};
- $introspector->add_method($method, $params, $returns, $interface);
+ my ($params, $returns, $interface, $attributes) = @{$exports->{methods}->{$method}};
+ $introspector->add_method($method, $params, $returns, $interface, $attributes);
}
foreach my $prop (keys %{$exports->{props}}) {
- my ($type, $access, $interface) = @{$exports->{props}->{$prop}};
- $introspector->add_property($prop, $type, $access, $interface);
+ 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) = @{$exports->{signals}->{$signal}};
- $introspector->add_signal($signal, $params, $interface);
+ my ($params, $interface, $attributes) = @{$exports->{signals}->{$signal}};
+ $introspector->add_signal($signal, $params, $interface, $attributes);
}
}
-
if (defined (*{"${class}::ISA"})) {
+ no strict "refs";
my @isa = @{"${class}::ISA"};
foreach my $parent (@isa) {
&_dbus_introspector_add($parent, $introspector);
@@ -399,70 +438,84 @@ sub _dbus_introspector_add {
sub dbus_method {
my $name = shift;
- my $params = shift;
- my $returns = shift;
-
- $params = [] unless defined $params;
- $returns = [] unless defined $returns;
-
+ my $params = [];
+ my $returns = [];
my $caller = caller;
- my $is = $dbus_exports{$caller};
-
- my $interface;
- if (@_) {
+ 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;
- } elsif (!exists $is->{interface}) {
- die "interface not specified & not default interface defined";
- } else {
- $interface = $is->{interface};
}
-
- $is->{methods}->{$name} = [$params, $returns, $interface];
+ if (@_ && ref($_[0]) eq "HASH") {
+ %attributes = %{$_[0]};
+ }
+
+ if (!$interface) {
+ die "interface not specified & no default interface defined";
+ }
+
+ $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes];
}
sub dbus_property {
my $name = shift;
- my $type = shift;
- my $access = shift;
-
- $access = "readwrite" unless defined $access;
-
+ my $type = "string";
+ my $access = "readwrite";
my $caller = caller;
- my $is = $dbus_exports{$caller};
-
- my $interface;
- if (@_) {
+ my $interface = $dbus_exports{$caller}->{interface};
+ my %attributes;
+
+ if (@_ && !ref($_[0])) {
+ $type = shift;
+ }
+ if (@_ && !ref($_[0])) {
+ $access = shift;
+ }
+ if (@_ && !ref($_[0])) {
$interface = shift;
- } elsif (!exists $is->{interface}) {
- die "interface not specified & not default interface defined";
- } else {
- $interface = $is->{interface};
}
-
- $is->{props}->{$name} = [$type, $access, $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];
}
sub dbus_signal {
my $name = shift;
- my $params = shift;
-
- $params = [] unless defined $params;
-
+ my $params = [];
my $caller = caller;
- my $is = $dbus_exports{$caller};
+ my $interface = $dbus_exports{$caller}->{interface};
+ my %attributes;
- my $interface;
- if (@_) {
+ if (@_ && ref($_[0]) eq "ARRAY") {
+ $params = shift;
+ }
+ if (@_ && !ref($_[0])) {
$interface = shift;
- } elsif (!exists $is->{interface}) {
- die "interface not specified & not default interface defined";
- } else {
- $interface = $is->{interface};
}
-
- $is->{signals}->{$name} = [$params, $interface];
+ if (@_ && ref($_[0]) eq "HASH") {
+ %attributes = %{$_[0]};
+ }
+
+ if (!$interface) {
+ die "interface not specified & no default interface defined";
+ }
+
+ $dbus_exports{$caller}->{signals}->{$name} = [$params, $interface, \%attributes];
}
1;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list