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