NetworkInfo::Discovery::Rendezvous - NetworkInfo::Discovery extension to find Rendezvous services

    use NetworkInfo::Discovery::Rendezvous;

    my $scanner = new NetworkInfo::Discovery::Rendezvous domain => 'example.net';
    $scanner->do_it;

    # print the list of services sorted by host
    for my $host ($scanner->get_interfaces) {
        printf "%s (%s)\n", $host->{nodename}, $host->{ip};

        for my $service (@{$host->{services}}) {
            printf "  %s (%s:%d)\n", $service->{name}, $service->{protocol}, $service->{port}
        }
    }

    # print the list of services by service name
    for my $service (sort {$a->{name} cmp $b->{name}} $scanner->get_services) {
        printf "--- %s ---\n", $service->{name};

        for my $host (sort @{$service->{hosts}}) {
            printf "  %s (%s:%s:%d)\n    %s\n", $host->{nodename}, $host->{ip}, 
                $host->{services}[0]{protocol}, $host->{services}[0]{port}
        }
    }

package NetworkInfo::Discovery::Rendezvous;
use strict;
use Carp;
use Encode;
use Net::Rendezvous;
use NetworkInfo::Discovery::Detect;
#use Data::Dumper; $Data::Dumper::Indent = 0; $Data::Dumper::Terse = 1;

{ no strict;
  $VERSION = '0.06';
  @ISA = qw(NetworkInfo::Discovery::Detect);
}

sub new {
    my $class = shift;
    my $self = $class->SUPER::new();
    my %args = @_;
    #printf STDERR ">>> new(): args=(%s)\n", join ', ', map{Dumper($_)}@_;
    
    $class = ref($class) || $class;
    bless $self, $class;
    
    # add private fiels
    $self->{_domains_to_scan} ||= [];
    
    # treat given arguments
    for my $attr (keys %args) {
        $self->$attr($args{$attr}) if $self->can($attr);
    }
    
    return $self
}

sub do_it {
    my $self = shift;
    
    for my $domain (@{$self->{_domains_to_scan}}) {
        # first, try to find all registered services in the domain
        my @services = Net::Rendezvous->all_services;
        
        # if services enumeration worked, try to find all instances of each service
        if(@services) {
            for my $service (@services) {
                $self->discover_service($service->service, $service->protocol, $domain)
            }
        
        # if it failed, try to find common services
        } else {
            $self->discover_service('afpovertcp', 'tcp', $domain);  # AFP over TCP shares
            $self->discover_service('ipp',        'tcp', $domain);  # CUPS servers
            $self->discover_service('presence',   'tcp', $domain);  # iChat nodes
            $self->discover_service('printer',    'tcp', $domain);  # printing servers
            $self->discover_service('workstation','tcp', $domain);  # workgroup manager
        }
    }
    
    # group services
    for my $host ($self->get_interfaces) {
        for my $service (@{$host->{services}}) {
            my $name = $service->{name};
            $self->{servicelist}{$name}{name} ||= $name;
            push @{$self->{servicelist}{$name}{hosts}}, $host
        }
    }
    
    # return list of found hosts
    return $self->get_interfaces
}

sub get_services { return values %{$_[0]->{servicelist}} }

sub discover_service {
    my $self = shift;
    my($service,$protocol,$domain) = @_;
    #printf STDERR ">>> discover_service(): args=(%s)\n", join ', ', map{Dumper($_)}@_;
    
    my $rsrc = new Net::Rendezvous;
    $rsrc->application($service, $protocol);
    $rsrc->domain($domain);
    $rsrc->discover;
    
    for my $entry ($rsrc->entries) {
        # host name: $entry->name
        # host addr: $entry->address
        # host services: 
        #   > this service: 
        #       service name: $service
        #       service fqdn: $entry->fqdn
        #       service port: $entry->port
        #       service attr: $entry->all_attrs
        $self->add_interface({
            ip => $entry->address, nodename => $entry->name, services => [{
                name => $service, port => $entry->port, protocol => $protocol, 
                fqdn => $entry->fqdn, attrs => { map {decode('utf-8',$_)} $entry->all_attrs }
            }]
        })
    }
}

sub domain {
    my $self = shift;
    if(ref $_[0] eq 'ARRAY') {
        push @{$self->{_domains_to_scan}}, @{$_[0]}
    } elsif(ref $_[0]) {
        croak "Don't know how to deal with a ", lc(ref($_[0])), "ref."
    } else {
        push @{$self->{_domains_to_scan}}, @_
    }
}

1; # End of NetworkInfo::Discovery::Rendezvous