home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / lib / perl5 / Net / DBus / Dumper.pm < prev    next >
Encoding:
Perl POD Document  |  2006-04-13  |  5.7 KB  |  236 lines
  1. # -*- perl -*-
  2. #
  3. # Copyright (C) 2004-2005 Daniel P. Berrange
  4. #
  5. # This program is free software; you can redistribute it and/or modify
  6. # it under the terms of the GNU General Public License as published by
  7. # the Free Software Foundation; either version 2 of the License, or
  8. # (at your option) any later version.
  9. #
  10. # This program is distributed in the hope that it will be useful,
  11. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. # GNU General Public License for more details.
  14. #
  15. # You should have received a copy of the GNU General Public License
  16. # along with this program; if not, write to the Free Software
  17. # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18. #
  19. # $Id: Dumper.pm,v 1.9 2006/01/27 15:34:23 dan Exp $
  20.  
  21. =pod
  22.  
  23. =head1 NAME
  24.  
  25. Net::DBus::Dumper - Stringify Net::DBus objects suitable for printing
  26.  
  27. =head1 SYNOPSIS
  28.  
  29.   use Net::DBus::Dumper;
  30.  
  31.   use Net::DBus;
  32.  
  33.   # Dump out info about the bus
  34.   my $bus = Net::DBus->find;
  35.   print dbus_dump($bus);
  36.  
  37.   # Dump out info about a service
  38.   my $service = $bus->get_service("org.freedesktop.DBus");
  39.   print dbus_dump($service);
  40.  
  41.   # Dump out info about an object
  42.   my $object = $service->get_object("/org/freedesktop/DBus");
  43.   print dbus_dump($object);
  44.  
  45. =head1 DESCRIPTION
  46.  
  47. This module serves as a debugging aid, providing a means to stringify
  48. a DBus related object in a form suitable for printing out. It can 
  49. stringify any of the Net::DBus:* objects, generating the following
  50. information for each
  51.  
  52. =over 4
  53.  
  54. =item Net::DBus
  55.  
  56. A list of services registered with the bus
  57.  
  58. =item Net::DBus::Service
  59. =item Net::DBus::RemoteService
  60.  
  61. The service name
  62.  
  63. =item Net::DBus::Object
  64. =item Net::DBus::RemoteObject
  65.  
  66. The list of all exported methods, and signals, along with their
  67. parameter and return types.
  68.  
  69. =back
  70.  
  71. =head1 METHODS
  72.  
  73. =over 4
  74.  
  75. =cut
  76.  
  77. package Net::DBus::Dumper;
  78.  
  79. use strict;
  80. use warnings;
  81.  
  82. use Exporter;
  83.  
  84. use vars qw(@EXPORT);
  85.  
  86. @EXPORT = qw(dbus_dump);
  87.  
  88.  
  89. =item my @data = dbus_dump($object);
  90.  
  91. Generates a stringified representation of an object. The object
  92. passed in as the parameter must be an instance of one of L<Net::DBus>, 
  93. L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
  94. L<Net::DBus::RemoteObject>, L<Net::DBus::Object>. The stringified
  95. representation will be returned as a list of strings, with newlines
  96. in appropriate places, such that it can be passed string to the C<print>
  97. method.
  98.  
  99. =cut
  100.  
  101. sub dbus_dump {
  102.     my $object = shift;
  103.     
  104.     my $ref = ref($object);
  105.     die "object '$object' is not a reference" unless defined $ref;
  106.     
  107.     if ($object->isa("Net::DBus::Object") ||
  108.     $object->isa("Net::DBus::RemoteObject")) {
  109.     return &_dbus_dump_introspector($object->_introspector);
  110.     } elsif ($object->isa("Net::DBus::RemoteService") ||
  111.          $object->isa("Net::DBus::Service")) {
  112.     return &_dbus_dump_service($object);
  113.     } elsif ($object->isa("Net::DBus")) {
  114.     return &_dbus_dump_bus($object);
  115.     }
  116. }
  117.  
  118.  
  119. sub _dbus_dump_introspector {
  120.     my $ins = shift;
  121.     
  122.     my @data;
  123.     push @data, "Object: ", $ins->get_object_path, "\n";
  124.     foreach my $interface ($ins->list_interfaces) {
  125.     push @data, "  Interface: ", $interface, "\n";
  126.     foreach my $method ($ins->list_methods($interface)) {
  127.         push @data, "    Method: ", $method, "\n";
  128.         foreach my $param ($ins->get_method_params($interface, $method)) {
  129.         push @data, &_dbus_dump_types("      > ", $param);
  130.         }
  131.         foreach my $param ($ins->get_method_returns($interface, $method)) {
  132.         push @data, &_dbus_dump_types("      < ", $param);
  133.         }
  134.     }
  135.     foreach my $signal ($ins->list_signals($interface)) {
  136.         push @data, "    Signal: ", $signal, "\n";
  137.         foreach my $param ($ins->get_signal_params($interface, $signal)) {
  138.         push @data, &_dbus_dump_types("      > ", $param);
  139.         }
  140.     }
  141.     }
  142.     return @data;
  143. }
  144.  
  145. sub _dbus_dump_types {
  146.     my $indent = shift;
  147.     my $type = shift;
  148.     
  149.     my @data;
  150.     if (ref($type)) {
  151.     push @data, $indent, $type->[0], "\n";
  152.     for (my $i = 1 ; $i <= $#{$type} ; $i++) {
  153.         push @data, &_dbus_dump_types($indent . "  ", $type->[$i]);
  154.     }
  155.     } else {
  156.     push @data, $indent, $type, "\n";
  157.     }
  158.     return @data;
  159. }
  160.  
  161.  
  162. sub _dbus_dump_service {
  163.     my $service = shift;
  164.     
  165.     my @data;
  166.     push @data, "Service: ", $service->get_service_name, "\n";
  167.     
  168.     my @objects = &_dbus_dump_children($service, "/");
  169.     foreach (@objects) {
  170.     push @data, "  Object: $_\n";
  171.     }
  172.     return @data;
  173. }
  174.  
  175. sub _dbus_dump_children {
  176.     my $service = shift;
  177.     my $path = shift;
  178.  
  179.     my $exp = $service->get_object($path);
  180.     my @exports = eval {
  181.     my $ins = $exp->_introspector;
  182.         if ($ins) {
  183.         return $ins->list_children;
  184.         }
  185.     return ();
  186.     };
  187.     my @objects = map { $path eq "/" ? $path . $_ : $path . "/" . $_ } @exports;
  188.     if ($@) {
  189.     #push @objects, " Could not lookup objects under path '$path'\n";
  190.     }
  191.     foreach my $child (@exports) {
  192.     push @objects, _dbus_dump_children ($service, $path eq "/" ? $path . $child : $path . "/" . $child);
  193.     }
  194.     return @objects;
  195. }
  196.  
  197. sub _dbus_dump_bus {
  198.     my $bus = shift;
  199.     
  200.     my @data;
  201.     push @data, "Bus: \n";
  202.     
  203.     
  204.     my $dbus = $bus->get_service("org.freedesktop.DBus");
  205.     my $obj = $dbus->get_object("/org/freedesktop/DBus");
  206.     my $names = $obj->ListNames();
  207.     
  208.     foreach (sort { $a cmp $b } @{$names}) {
  209.     push @data, "  Service: ", $_, "\n";
  210.     }
  211.     return @data;
  212. }
  213.  
  214. 1;
  215.  
  216. =pod
  217.  
  218. =back
  219.  
  220. =head1 BUGS
  221.  
  222. It should print out a list of object paths registered against a
  223. service, but this only currently works for service implemented
  224. in Perl
  225.  
  226. =head1 SEE ALSO
  227.  
  228. L<Net::DBus>, L<Net::DBus::RemoteService>, L<Net::DBus::Service>, 
  229. L<Net::DBus::RemoteObject>, L<Net::DBus::Object>, L<Data::Dumper>.
  230.  
  231. =head1 COPYRIGHT
  232.  
  233. Copyright 2005 Daniel Berrange <dan@berrange.com>
  234.  
  235. =cut
  236.