Bug #45034 for Net-DBus: Net::DBus dbus_strict_exports [patch]

Hi Daniel, here is the newer patch according to your suggestions. Thanks. Greetings.

diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Binding/Introspector.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Binding/Introspector.pm 2009-04-15 14:05:49.732160398 +0200 @@ -149,6 +149,8 @@ $self->{children} = exists $params{children} ? $params{children} : []; } + $self->{strict} = defined $params{strict}; + # 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} && @@ -209,14 +211,42 @@ my $self = shift; my $name = shift; - my @interfaces; - foreach my $interface (keys %{$self->{interfaces}}) { - if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { - push @interfaces, $interface; + 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; } +} - return @interfaces; +=item my @interfaces = $ins->can_do_method($object, $name) + +Checks according to C<dbus_strict_exports()> wether the C<$object> +supports the method or not. If you used C<dbus_strict_exports()>, then +only methods which were exported earlier through C<dbus_method()> will +be allowed. Otherwise simply C<$object> will be checked with can(). + +=cut + +sub can_do_method { + my $self = shift; + # for some reason using caller() didn't work, so in this way. + my $caller = shift; + my $method_name = shift; + + if ($self->{strict}) { + return $self->has_method($method_name, @_); + } else { + return $caller->can($method_name); + } } =item my @interfaces = $ins->has_signal($name) diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Exporter.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Exporter.pm 2009-04-15 14:05:41.336206453 +0200 @@ -250,7 +250,7 @@ use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(dbus_method dbus_signal dbus_property); +@EXPORT = qw(dbus_method dbus_signal dbus_property dbus_strict_exports); sub import { @@ -305,7 +305,7 @@ } unless (exists $dbus_introspectors{$class}) { - my $is = Net::DBus::Binding::Introspector->new(); + my $is = Net::DBus::Binding::Introspector->new(strict=>$dbus_exports{$class}->{strict}); &_dbus_introspector_add($class, $is); $dbus_introspectors{$class} = $is; } @@ -400,6 +400,19 @@ $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $param_names, $return_names]; } +=item dbus_strict_exports(); + +Restricts calls to only methods already exported through C<dbus_method>. +When not using this method, by default any method call will be allowed. + +Method calls will be also restricted according to the used interface. + +=cut + +sub dbus_strict_exports { + my $caller = caller; + $dbus_exports{$caller}->{strict} = 1; +} =item dbus_property($name, $type, $access, [\%attributes]); diff -uraN libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm --- libnet-dbus-perl-0.33.6.orig/lib/Net/DBus/Object.pm 2008-02-21 01:26:44.000000000 +0100 +++ libnet-dbus-perl-0.33.6/lib/Net/DBus/Object.pm 2009-04-15 14:05:31.884227634 +0200 @@ -488,7 +488,7 @@ } elsif ($method_name eq "Set") { $reply = $self->_dispatch_prop_write($connection, $message); } - } elsif ($self->can($method_name)) { + } elsif ($self->_introspector->can_do_method($self, $method_name, $interface)) { my $ins = $self->_introspector; my @ret = eval { my @args;