package Net::Bonjour; =head1 NAME Net::Bonjour - Module for DNS service discovery (Apple's Bonjour) =head1 SYNOPSIS use Net::Bonjour; my $res = Net::Bonjour->new([, ]); $res->discover; foreach my $entry ( $res->entries ) { printf "%s %s:%s\n", $entry->name, $entry->address, $entry->port; } Or the cyclical way: use Net::Bonjour; my $res = Net::Bonjour->new([, ]); $res->discover; while ( 1 ) { foreach my $entry ( $res->entries ) { print $entry->name, "\n"; } $res->discover; } =head1 DESCRIPTION Net::Bonjour is a set of modules that allow one to discover local services via multicast DNS (mDNS) or enterprise services via traditional DNS. This method of service discovery has been branded as Bonjour by Apple Computer. =head2 Base Object The base object would be of the Net::Bonjour class. This object contains the resolver for DNS service discovery. =head2 Entry Object The base object (Net::Bonjour) will return entry objects of the class L. =head1 METHODS =head2 new([, , ]) Creates a new Net::Bonjour discovery object. First argument specifies the service to discover, e.g. http, ftp, afpovertcp, and ssh. The second argument specifies the protocol, i.e. tcp or udp. I. The third argument specifies the discovery domain, the default is 'local'. If no arguments are specified, the resulting Net::Bonjour object will be empty and will not perform an automatic discovery upon creation. =head2 all_services([]) Returns an array of new Net::Renedezvous objects for each service type advertised in the domain. The argument specifies the discovery domain, the default is 'local'. Please note that the resulting Net::Bonjour objects will not have performed a discovery during the creation. Therefore, the discovery process will need to be run prior to retriving a list of entries for that Net::Bonjour object. =head2 domain([]) Get/sets current discovery domain. By default, the discovery domain is 'local'. Discovery for the 'local' domain is done via MDNS while all other domains will be done via traditional DNS. =head2 discover Repeats the discovery process and reloads the entry list from this discovery. =head2 entries Returns an array of L objects for the last discovery. =head2 protocol([]) Get/sets current protocol of the service type, i.e. TCP or UDP. Please note that this is not the protocol for DNS connection. =head2 service([]) Get/sets current service type. =head2 shift_entry Shifts off the first entry of the last discovery. The returned object will be a L object. =head1 EXAMPLES =head2 Print out a list of local websites print "Local Websites"; use Net::Bonjour; my $res = Net::Bonjour->new('http'); $res->discover; foreach my $entry ( $res->entries) { printf "%s
", $entry->address, $entry->attribute('path'), $entry->name; } print ""; =head2 Find a service and connect to it use Socket; use Net::Bonjour; my $res = Net::Bonjour->new('custom'); $res->discover; my $entry = $res->shift_entry; socket SOCK, PF_INET, SOCK_STREAM, scalar(getprotobyname('tcp')); connect SOCK, $entry->sockaddr; print SOCK "Send a message to the service"; while ($line = ) { print $line; } close SOCK; =head2 Find all service types and print. use Net::Bonjour; foreach my $res ( Net::Bonjour->all_services ) { printf "%s (%s)\n", $res->service, $res->protocol; } =head2 Find and print all service types and entries. use Net::Bonjour; foreach my $res ( Net::Bonjour->all_services ) { printf "-- %s (%s) ---\n", $res->service, $res->protocol; $res->discover; foreach my $entry ( $res->entries) { printf "\t%s (%s:%s)\n", $entry->name, $entry->address, $entry->port; } } =head1 SEE ALSO L =head1 COPYRIGHT This library is free software and can be distributed or modified under the same terms as Perl itself. Bonjour (in this context) is a trademark of Apple Computer, Inc. =head1 AUTHORS The Net::Bonjour module was created by George Chlipala =cut use strict; use vars qw($VERSION $AUTOLOAD); use Net::DNS; use Net::Bonjour::Entry; use Socket; $VERSION = '0.96'; sub new { my $self = {}; bless $self, shift; $self->_init(@_); return $self; } sub _init { my $self = shift; $self->{'_dns_server'} = [ '224.0.0.251' ]; $self->{'_dns_port'} = '5353'; $self->{'_dns_domain'} = 'local'; if (@_) { $self->domain(pop) if $_[$#_] =~ /\./; $self->service(@_); $self->discover; } return; } sub service { my $self = shift; if (@_) { $self->{'_service'} = shift; $self->{'_proto'} = shift || 'tcp'; } return $self->{'_service'}; } sub application { my $self = shift; return $self->service(@_); } sub protocol { my $self = shift; if (@_) { $self->{'_proto'} = shift; } return $self->{'_proto'}; } sub fqdn { my $self = shift; return sprintf '_%s._%s.%s', $self->{'_service'}, $self->{'_proto'}, $self->{'_dns_domain'}; } sub dns_refresh { my $self = shift; my $resolv = Net::DNS::Resolver->new(); my $query = $resolv->query($self->fqdn, 'PTR'); return 0 if $query eq ''; $self->{'_dns_server'} = [$resolv->nameservers]; $self->{'_dns_port'} = $resolv->port; my @list; foreach my $rr ($query->answer) { next if $rr->type ne 'PTR'; push(@list, $rr->ptrdname); } return @list; } sub mdns_refresh { my $self = shift; my $query = Net::DNS::Packet->new($self->fqdn, 'PTR'); socket DNS, PF_INET, SOCK_DGRAM, scalar(getprotobyname('udp')); bind DNS, sockaddr_in(0,inet_aton('0.0.0.0')); send DNS, $query->data, 0, sockaddr_in($self->{'_dns_port'}, inet_aton($self->{'_dns_server'}[0])); my $rout = ''; my $rin = ''; my %list; vec($rin, fileno(DNS), 1) = 1; while ( select($rout = $rin, undef, undef, 1.0) ) { my $data; recv(DNS, $data, 1000, 0); my($ans,$err) = Net::DNS::Packet->new(\$data, $self->{'_debug'}); next if $query->header->id != $ans->header->id; foreach my $rr ($ans->answer) { next if $rr->type ne 'PTR'; $list{$rr->ptrdname} = 1; } } return keys(%list); } sub entries { my $self = shift; return @{$self->{'_results'}}; } sub shift_entry { my $self = shift; return shift(@{$self->{'_results'}}); } sub domain { my $self = shift; if ( @_ ) { $self->{'_dns_domain'} = shift; $self->{'_dns_domain'} =~ s/(^\.|\.$)//; } return $self->{'_dns_domain'}; } sub refresh { my $self = shift; return $self->discover(@_); } sub discover { my $self = shift; my @list; my $ptrs = []; if ( $self->domain(@_) eq 'local' ) { @list = $self->mdns_refresh; } else { @list = $self->dns_refresh; } foreach my $x ( 0..$#list ) { my $host = Net::Bonjour::Entry->new($list[$x]); $host->dns_server($self->{'_dns_server'}); $host->dns_port($self->{'_dns_port'}); $host->fetch; $list[$x] = $host; } $self->{'_results'} = [ @list ]; return scalar(@list); } sub all_services { my $self = {}; bless $self, shift; $self->_init; $self->service('services._dns-sd', 'udp'); my @list; if ( $self->domain(@_) eq 'local' ) { @list = $self->mdns_refresh; } else { @list = $self->dns_refresh; } foreach my $i ( 0..$#list ) { next unless $list[$i] =~ /^_(.+)\._(\w+)/; my $srvc = Net::Bonjour->new(); $srvc->service($1, $2); $srvc->domain($self->domain); $list[$i] = $srvc; } return @list; } sub AUTOLOAD { my $self = shift; my $key = $AUTOLOAD; $key =~ s/^.*:://; $key = '_' . $key; if ( @_ ) { $self->{$key} = shift; } return $self->{$key}; } 1;