r43354 - in /branches/upstream/libnet-bonjour-perl: ./ current/ current/demo/ current/lib/ current/lib/Net/ current/lib/Net/Bonjour/ current/lib/Net/Rendezvous/ current/t/
christine at users.alioth.debian.org
christine at users.alioth.debian.org
Tue Sep 1 00:44:27 UTC 2009
Author: christine
Date: Tue Sep 1 00:44:22 2009
New Revision: 43354
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=43354
Log:
[svn-inject] Installing original source of libnet-bonjour-perl
Added:
branches/upstream/libnet-bonjour-perl/
branches/upstream/libnet-bonjour-perl/current/
branches/upstream/libnet-bonjour-perl/current/ChangeLog
branches/upstream/libnet-bonjour-perl/current/MANIFEST
branches/upstream/libnet-bonjour-perl/current/META.yml
branches/upstream/libnet-bonjour-perl/current/Makefile.PL
branches/upstream/libnet-bonjour-perl/current/README
branches/upstream/libnet-bonjour-perl/current/demo/
branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl (with props)
branches/upstream/libnet-bonjour-perl/current/demo/demo.pl (with props)
branches/upstream/libnet-bonjour-perl/current/demo/list.cgi (with props)
branches/upstream/libnet-bonjour-perl/current/lib/
branches/upstream/libnet-bonjour-perl/current/lib/Net/
branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/
branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour.pm
branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/Entry.pm
branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/
branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous.pm
branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/Entry.pm
branches/upstream/libnet-bonjour-perl/current/t/
branches/upstream/libnet-bonjour-perl/current/t/1-use.t
branches/upstream/libnet-bonjour-perl/current/t/2-entry.t
branches/upstream/libnet-bonjour-perl/current/t/3-rendezvous.t
branches/upstream/libnet-bonjour-perl/current/t/4-enterprise.ot
Added: branches/upstream/libnet-bonjour-perl/current/ChangeLog
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/ChangeLog?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/ChangeLog (added)
+++ branches/upstream/libnet-bonjour-perl/current/ChangeLog Tue Sep 1 00:44:22 2009
@@ -1,0 +1,58 @@
+version 0.96: Sat Feb 28 12:26:00 CDT 2008
+ - [Jesse Vincent] Updated MakeFile.PL to allow automated CPAN installation.
+
+version 0.95: Sat Mar 17 22:11:00 CDT 2007
+ - [George Chlipala] Updated Net::Bonjour::Entry to handle special
+ characters, e.g. period and space, in DNS names. Updated
+ Makefile.PL to include license and abstract information.
+
+version 0.92: Sat Mar 17 19:27:00 CDT 2007
+ - [George Chlipala] Renamed to Net::Bonjour and added legacy
+ support for Net::Rendezvous
+
+version 0.91: Sat Mar 17 17:43:00 CDT 2007
+ - [bmat] Fixed bug #25292: Converting _txtdata to _attr truncates
+ if more than 1 equals sign
+ - [George Chlipala] other cleanup in Entry.pm
+
+version 0.90: Mon Dec 27 16:20:00 CDT 2004
+
+ - [George Chlipala] Added service and protocol functions.
+ Added all_services function based on enumerate_services function by
+ Sébastien Aperghis-Tramoni. General code clean up.
+
+version 0.86: Sat Mar 06 13:30:00 CDT 2004
+
+ - [George Chlipala] Fixed test #3 (t/3-enterprise.t).
+
+version 0.85: Fri Mar 05 20:00:00 CDT 2004
+
+ - [George Chlipala] updated 'application' method in base object to
+ use current domain setting. Fixed tradition DNS discovery method.
+ Added third test (3-enterprise.t). This test will test against the
+ ftp entries at zeroconf.org
+
+version 0.80: Wed Mar 03 21:00:00 CDT 2004
+
+ - [George Chlipala] Setup test directory and moved test.pl to t/use.t
+ Setup t/entry.t test. Added discover function to Net::Rendezvous.
+ Added META.yml file. Added support for traditional DNS based service
+ discovery and ability to set discovery domain.
+
+version 0.70 Tue Feb 17 10:00:00 CDT 2004
+
+ - [Dan Sully] General code clean up and added basic test script
+ (test.pl).
+ - [George Chlipala] Added support to export DNS records (dnsrr) and
+ all_attrs method for Net::Rendezvous::Entry objects.
+
+version 0.51: Web Feb 11 10:31:00 CDT 2004
+
+ - [George Chlipala] Fixed POD documentation for Net::Rendezvous, added
+ trademark disclaimer, added URLs in README, and updated examples in
+ Net::Rendezvous and Net::Rendezvous::Entry PODs.
+
+version 0.50: Tue Feb 10 20:16:00 CDT 2004
+
+ - [George Chlipala] Initial release.
+
Added: branches/upstream/libnet-bonjour-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/MANIFEST?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/MANIFEST (added)
+++ branches/upstream/libnet-bonjour-perl/current/MANIFEST Tue Sep 1 00:44:22 2009
@@ -1,0 +1,16 @@
+ChangeLog
+MANIFEST This File
+Makefile.PL Perl MakeMaker Makefile
+README
+demo/demo.pl
+demo/list.cgi
+demo/all_services.pl
+lib/Net/Bonjour.pm
+lib/Net/Bonjour/Entry.pm
+lib/Net/Rendezvous.pm
+lib/Net/Rendezvous/Entry.pm
+t/1-use.t
+t/2-entry.t
+t/3-rendezvous.t
+t/4-enterprise.ot
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libnet-bonjour-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/META.yml?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/META.yml (added)
+++ branches/upstream/libnet-bonjour-perl/current/META.yml Tue Sep 1 00:44:22 2009
@@ -1,0 +1,15 @@
+--- #YAML:1.0
+name: Net-Bonjour
+version: 0.96
+abstract: Module for DNS service discovery (Apple's Bonjour)
+license: perl
+generated_by: ExtUtils::MakeMaker version 6.32
+distribution_type: module
+requires:
+ Net::DNS: 0.5
+ Socket: 1.75
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
+author:
+ - George Chlipala <george at walnutcs.com>
Added: branches/upstream/libnet-bonjour-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/Makefile.PL?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/Makefile.PL (added)
+++ branches/upstream/libnet-bonjour-perl/current/Makefile.PL Tue Sep 1 00:44:22 2009
@@ -1,0 +1,24 @@
+use ExtUtils::MakeMaker;
+
+my $ans = prompt("Enable enterprise tests? [y/N]");
+
+my $tests = 't/*.t';
+
+if ( $ans =~ /^y/i ) {
+ print "Enterprise tests enabled.\n";
+ print "Enterprise test will query HTTP service records from zeroconf.org\n";
+ $tests = 't/*.t t/*.ot';
+} else {
+ print "Enterprise tests will be skipped.\n";
+}
+
+WriteMakefile(
+ 'NAME' => 'Net::Bonjour',
+ 'VERSION_FROM' => 'lib/Net/Bonjour.pm',
+ 'DISTNAME' => 'Net-Bonjour',
+ 'PREREQ_PM' => { 'Net::DNS' => 0.50, 'Socket' => 1.75 },
+ 'AUTHOR' => 'George Chlipala <george at walnutcs.com>',
+ 'ABSTRACT' => "Module for DNS service discovery (Apple's Bonjour)",
+ 'LICENSE' => 'perl',
+ 'test' => { 'TESTS' => $tests }
+)
Added: branches/upstream/libnet-bonjour-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/README?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/README (added)
+++ branches/upstream/libnet-bonjour-perl/current/README Tue Sep 1 00:44:22 2009
@@ -1,0 +1,47 @@
+This is Net::Bonjour, a set of perl modules to utilize DNS for service
+discovery. This method of service discovery is branded as Bonjour by
+Apple Computer. More information can be found at:
+
+http://www.zeroconf.org/
+http://developer.apple.com/macosx/bonjour/index.html
+
+A list of register service types can be found at:
+
+http://www.dns-sd.org/ServiceTypes.html
+
+Requirements:
+ perl >= 5.6.0
+ Net::DNS >= 0.50
+
+Install the library by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+Please report any bugs/suggestions to George Chlipala <george at walnutcs.com>
+
+NOTE FOR Net::Rendezvous USERS
+
+- As with the change by Apple, I have updated the module to use the "Bonjour" name.
+ I have added support for the Net::Rendezvous classes as subclasses of the cooresponding
+ Net::Bonjour classes. Although, I would suggest updating scripts to reflect the change.
+
+SPECIAL CHARACTERS IN DNS NAMES
+
+- Previous versions of Net::DNS (0.44) would have issues with special characters in DNS
+ names. Handling of special characters was added to Net::DNS with version 0.50 rc 1.
+ As of version 0.95, Net::Bonjour::Entry has been updated to recognize the escaped
+ characters and return an interpolated string when the name() method is called. This
+ update was tested against Net::DNS v0.59. If there are any irregularities with a lower
+ version, I suggest upgrading Net::DNS to v0.59.
+
+All files contained in this installation are Copyright (c) 2004
+George Chlipala unless otherwise specified. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+Bonjour (in this context) is a trademark of Apple Computer, Inc.
+
Added: branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl (added)
+++ branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl Tue Sep 1 00:44:22 2009
@@ -1,0 +1,11 @@
+#!/usr/bin/perl
+
+use Net::Bonjour;
+
+foreach my $res ( Net::Bonjour->all_services($ARGV[0] || 'local') ) {
+ 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;
+ }
+}
Propchange: branches/upstream/libnet-bonjour-perl/current/demo/all_services.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libnet-bonjour-perl/current/demo/demo.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/demo/demo.pl?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/demo/demo.pl (added)
+++ branches/upstream/libnet-bonjour-perl/current/demo/demo.pl Tue Sep 1 00:44:22 2009
@@ -1,0 +1,11 @@
+#!/usr/bin/perl
+
+use Net::Bonjour;
+
+my $res = new Net::Bonjour( @ARGV );
+print $res->domain(), "\n";
+$res->discover;
+
+foreach $entry ( $res->entries ) {
+ printf "%s %s:%s\n", $entry->name, $entry->hostname, $entry->port;
+}
Propchange: branches/upstream/libnet-bonjour-perl/current/demo/demo.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libnet-bonjour-perl/current/demo/list.cgi
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/demo/list.cgi?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/demo/list.cgi (added)
+++ branches/upstream/libnet-bonjour-perl/current/demo/list.cgi Tue Sep 1 00:44:22 2009
@@ -1,0 +1,16 @@
+#!/usr/bin/perl
+
+use Net::Bonjour;
+use CGI qw(:standard);
+
+print header, start_html('Bonjour Websites'), h1('Bonjour Websites'),
+ hr;
+
+my $res = new Net::Bonjour('http');
+$res->discover;
+
+foreach $entry ( $res->entries ) {
+ my $url = sprintf 'http://%s:%s%s', $entry->address, $entry->port,
+ $entry->attribute('path');
+ print a({-href=> $url}, $entry->name), br;
+}
Propchange: branches/upstream/libnet-bonjour-perl/current/demo/list.cgi
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour.pm?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour.pm (added)
+++ branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour.pm Tue Sep 1 00:44:22 2009
@@ -1,0 +1,361 @@
+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(<service>[, <protocol>]);
+
+ $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(<service>[, <protocol>]);
+
+ $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<Net::Bonjour::Entry>.
+
+=head1 METHODS
+
+=head2 new([<service>, <protocol>, <domain>])
+
+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 default protocol is TCP>. 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([<domain>])
+
+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([<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<Net::Renedezvous::Entry> objects for the last discovery.
+
+=head2 protocol([<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([<service type>])
+
+Get/sets current service type.
+
+=head2 shift_entry
+
+Shifts off the first entry of the last discovery. The returned object will be a L<Net::Bonjour::Entry> object.
+
+=head1 EXAMPLES
+
+=head2 Print out a list of local websites
+
+ print "<HTML><TITLE>Local Websites</TITLE>";
+
+ use Net::Bonjour;
+
+ my $res = Net::Bonjour->new('http');
+ $res->discover;
+
+ foreach my $entry ( $res->entries) {
+ printf "<A HREF='http://%s%s'>%s</A><BR>", $entry->address,
+ $entry->attribute('path'), $entry->name;
+ }
+
+ print "</HTML>";
+
+=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 = <SOCK>) { 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<Net::Bonjour::Entry>
+
+=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 <george at walnutcs.com>
+
+=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;
Added: branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/Entry.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/Entry.pm?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/Entry.pm (added)
+++ branches/upstream/libnet-bonjour-perl/current/lib/Net/Bonjour/Entry.pm Tue Sep 1 00:44:22 2009
@@ -1,0 +1,374 @@
+package Net::Bonjour::Entry;
+
+=head1 NAME
+
+Net::Bonjour::Entry - Support module for mDNS service discovery (Apple's Bonjour)
+
+=head1 SYNOPSIS
+
+use Net::Bonjour;
+
+my $res = Net::Bonjour->new(<service>[, <protocol>]);
+$res->discover;
+
+foreach my $entry ( $res->entries ) {
+ print $entry->name, "\n";
+}
+
+=head1 DESCRIPTION
+
+Net::Bonjour::Entry is a module used to manage entries returned by a mDNS
+service discovery (Apple's Bonjour). See L<Net::Bonjour> for more information.
+
+=head1 METHODS
+
+=head2 new([<fqdn>])
+
+Creates a new Net::Bonjour::Entry object. The optional argument defines the
+fully qualifed domain name (FQDN) of the entry. Normal usage of the
+L<Net::Bonjour> module will not require the construction of
+Net::Bonjour::Entry objects, as they are automatically created during the
+discovery process.
+
+=head2 address
+
+Returns the IP address of the entry.
+
+=head2 all_attrs
+
+Returns all the current attributes in the form of hashed array.
+
+=head2 attribute(<attribute>)
+
+Returns the specified attribute from the TXT record of the entry. TXT records
+are used to specify additional information, e.g. path for http.
+
+=head2 dnsrr([<record type>])
+
+Returns an DNS answer packet of the entry. The output will be in the format
+of a L<Net::DNS::Packet> object. The I<record type> designates the resource
+record to answer with, i.e. PTR, SRV, or TXT. The default is PTR.
+
+=head2 fetch
+
+Reloads the information for the entry via mDNS.
+
+=head2 fqdn
+
+Returns the fully qualifed domain name (FQDN) of entry. An example FQDN is server._afpovertcp._tcp.local
+
+=head2 hostname
+
+Returns the hostname of the server, e.g. 'server.local'.
+
+=head2 name
+
+Returns the name of the entry. In the case of the fqdn example, the name
+would be 'server'. This name may not be the hostname of the server. For
+example, names for presence/tcp will be the name of the user and http/tcp will
+be title of the web resource.
+
+=head2 port
+
+Returns the TCP or UDP port of the entry.
+
+=head2 sockaddr
+
+Returns the binary socket address for the resource and can be used directly to bind() sockets.
+
+=head1 EXAMPLES
+
+=head2 Print out a list of local websites
+
+ print "<HTML><TITLE>Local Websites</TITLE>";
+
+ use Net::Bonjour;
+
+ my $res = Net::Bonjour->new('http');
+ $res->discover;
+
+ foreach my $entry ( $res->entries) {
+ printf "<A HREF='http://%s%s'>%s</A><BR>",
+ $entry->address, $entry->attribute('path'),
+ $entry->name;
+ }
+
+ print "</HTML>";
+
+=head2 Find a service and connect to it
+
+ 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 = <SOCK>) { print $line; }
+
+ close SOCK;
+
+=head1 SEE ALSO
+
+L<Net::Bonjour>
+
+=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::Entry module was created by George Chlipala <george at walnutcs.com>
+
+=cut
+
+use strict;
+use vars qw($AUTOLOAD);
+use Socket;
+use Net::DNS;
+
+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->{'_ip_type'} = 'A';
+ $self->{'_index'} = 0;
+ $self->{'_ttl'} = 3600;
+ if ( ref($_[0]) eq 'HASH') {
+ my $attrs = shift;
+ foreach my $k ( keys(%{$attrs}) ) {
+ $self->{'_' . $k} = $attrs->{$k};
+ }
+ $self->all_attrs if ref( $attrs->{'attr'} ) eq 'HASH';
+ } elsif ( $#_ == 0 ) {
+ $self->fqdn(shift);
+ }
+ return;
+}
+
+sub fetch {
+ my $self = shift;
+
+ my $res = Net::DNS::Resolver->new(
+ nameservers => $self->{'_dns_server'},
+ port => $self->{'_dns_port'}
+ );
+
+ my ($name, $protocol, $ipType) = split(/(?<!\\)\./, $self->fqdn,3);
+
+ $self->{'_name'} = $name;
+ $self->type($protocol, $ipType);
+
+ my $srv = $res->query($self->fqdn(), 'SRV') || return;
+ my $srvrr = ($srv->answer)[0];
+
+ $self->priority($srvrr->priority);
+ $self->weight($srvrr->weight);
+ $self->port($srvrr->port);
+ $self->hostname($srvrr->target);
+
+ if ($srv->additional) {
+ foreach my $additional ($srv->additional) {
+ $self->{'_' . uc($additional->type)} = $additional->address;
+ }
+ } else {
+ my $aquery = $res->query($srvrr->target, 'A');
+ my $arr = ($aquery->answer)[0];
+ if ( $arr->type eq 'A' ) {
+ $self->{'_' . uc($arr->type)} = $arr->address;
+ }
+ }
+
+ my $txt = $res->query($self->fqdn, 'TXT');
+
+ # Text::Parsewords, which is called by Net::DNS::RR::TXT can spew
+ if ( $txt ) {
+ local $^W = 0;
+ my $txti = 0;
+
+ foreach my $txtrr ( $txt->answer ) {
+ $self->txtdata([$txtrr->char_str_list ]);
+ $self->index($txti++);
+ foreach my $txtln ( $txtrr->char_str_list ) {
+ my ($key,$val) = split(/=/,$txtln,2);
+ $self->attribute($key, $val);
+ }
+ $txti++;
+ }
+ }
+
+ $self->text($txt);
+
+ return;
+}
+
+sub all_attrs {
+ my $self = shift;
+ my $index = $self->index;;
+ if ( @_ ) {
+ my $hash = shift;
+ $index = (shift || 0);
+ $self->{'_attr'}[$index] = { %{$hash} };
+ }
+ my @txts;
+ foreach ( keys(%{$self->{'_attr'}[$index]}) ) {
+ push(@txts, sprintf('%s=%s', $_, $self->{'_attr'}[$index]{$_}));
+ }
+ $self->txtdata( \@txts );
+ return %{$self->{'_attr'}[$index]};
+}
+
+sub attribute {
+ my $self = shift;
+ my $key = shift;
+ my $index = $self->index;
+ if ( @_ ) {
+ $self->{'_attr'}[$index]{$key} = shift;
+ }
+ return $self->{'_attr'}[$index]{$key};
+}
+
+sub type {
+ my $self = shift;
+ if ( @_ ) {
+ my $type = sprintf '%s/%s', shift, shift;
+ $type =~ s/_//g;
+ $self->{'_type'} = $type;
+ }
+ return $self->{'_type'};
+}
+
+sub address {
+ my $self = shift;
+ my $key = '_' . $self->{'_ip_type'};
+ if ( @_ ) {
+ $self->{$key} = shift;
+ }
+ return $self->{$key};
+}
+
+sub sockaddr {
+ my $self = shift;
+ return sockaddr_in($self->port, inet_aton($self->address));
+}
+
+sub dnsrr {
+ my $self = shift;
+ my $type = uc(shift);
+
+ my $packet;
+
+ my $srv = Net::DNS::RR->new(
+ 'type' => 'SRV',
+ 'ttl' => $self->ttl,
+ 'name' => $self->fqdn,
+ 'port' => $self->port,
+ 'priority' => ( $self->priority || 0 ),
+ 'weight' => ( $self->weight || 0 ),
+ 'target' => $self->hostname
+ );
+
+ my $txt = Net::DNS::RR->new(
+ 'type' => 'TXT',
+ 'ttl' => $self->ttl,
+ 'name' => $self->fqdn,
+ 'char_str_list' => $self->txtdata
+ );
+
+ if ($type eq 'SRV') {
+
+ $packet = Net::DNS::Packet->new($self->fqdn, 'SRV', 'IN');
+ $packet->push('answer', $srv);
+
+ } elsif ($type eq 'TXT') {
+
+ $packet = Net::DNS::Packet->new($self->fqdn, 'TXT', 'IN');
+ $packet->push('answer', $txt);
+
+ } else {
+
+ my $app = (split(/\./, $self->fqdn,2))[1];
+
+ $packet = Net::DNS::Packet->new($app, 'PTR', 'IN');
+
+ $packet->push('answer', Net::DNS::RR->new(
+ 'type' => 'PTR',
+ 'ttl' => $self->ttl,
+ 'ptrdname' => $self->fqdn,
+ 'name' => $app
+ ));
+
+ $packet->push('additional', $srv, $txt);
+ }
+
+ $packet->header->qr(1);
+ $packet->header->aa(1);
+ $packet->header->rd(0);
+
+ my @addrs = ();
+
+ foreach my $type (qw(A AAAA)) {
+
+ my $rr = Net::DNS::RR->new(
+ 'type' => $type,
+ 'ttl' => $self->ttl,
+ 'address' => $self->{'_' . $type},
+ 'name' => $self->hostname
+ );
+
+ push(@addrs, $rr) if $self->{'_' . $type};
+ }
+
+ $packet->push('additional', @addrs);
+ return $packet;
+}
+
+sub name {
+ my $self = shift;
+ if ( $_[0] ) {
+ $self->{'_name'} = quotemeta($_[0]);
+ }
+ my $name = $self->{'_name'};
+ $name =~ s/\\([0-9]{3})/chr($1)/ge;
+ $name =~ s/\\x([0-9A-Fa-f]{2})/chr(hex($1))/ge;
+ $name =~ s/\\(.)/$1/g;
+ return $name;
+}
+
+sub txtdata {
+ my $self = shift;
+ my $index = $self->index;
+ if ( ref($_[0]) eq 'ARRAY' ) {
+ my $list = shift;
+ $self->{'_txtdata'}[$index] = [ @{$list} ];
+ }
+ return $self->{'_txtdata'}[$index];
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $key = $AUTOLOAD;
+ $key =~ s/^.*:://;
+ $key = '_' . $key;
+ if ( @_ ) {
+ $self->{$key} = shift;
+ }
+ return $self->{$key};
+}
+
+1;
Added: branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous.pm?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous.pm (added)
+++ branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous.pm Tue Sep 1 00:44:22 2009
@@ -1,0 +1,35 @@
+package Net::Rendezvous;
+
+=head1 NAME
+
+Net::Rendezvous - Module for DNS service discovery (Apple's Rendezvous)
+
+=head1 SYNOPSIS
+
+B<This module is deprecated. Use L<Net::Bonjour>>.
+
+=head1 SEE ALSO
+
+L<Net::Bonjour>
+
+=head1 COPYRIGHT
+
+This library is free software and can be distributed or modified under the same terms as Perl itself.
+
+Rendezvous (in this context) is a trademark of Apple Computer, Inc.
+Bonjour (in this context) is a trademark of Apple Computer, Inc.
+
+=head1 AUTHORS
+
+The Net::Rendezvous module was created by George Chlipala <george at walnutcs.com>
+
+=cut
+
+use strict;
+use Net::Bonjour;
+use Net::Rendezvous::Entry;
+use vars qw($VERSION $AUTOLOAD @ISA);
+our $VERSION = '0.92';
+our @ISA = ('Net::Bonjour');
+
+1;
Added: branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/Entry.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/Entry.pm?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/Entry.pm (added)
+++ branches/upstream/libnet-bonjour-perl/current/lib/Net/Rendezvous/Entry.pm Tue Sep 1 00:44:22 2009
@@ -1,0 +1,33 @@
+package Net::Rendezvous::Entry;
+
+=head1 NAME
+
+Net::Rendezvous::Entry - Support module for mDNS service discovery (Apple's Rendezvous)
+
+=head1 SYNOPSIS
+
+B<This module is deprecated. Please see L<Net::Bonjour::Entry> and L<Net::Bonjour>>
+
+=head1 SEE ALSO
+
+L<Net::Bonjour>
+
+=head1 COPYRIGHT
+
+This library is free software and can be distributed or modified under the same terms as Perl itself.
+
+Rendezvous (in this context) is a trademark of Apple Computer, Inc.
+Bonjour (in this context) is a trademark of Apple Computer, Inc.
+
+=head1 AUTHORS
+
+The Net::Rendezvous::Entry module was created by George Chlipala <george at walnutcs.com>
+
+=cut
+
+use strict;
+use Net::Bonjour::Entry;
+use vars qw($AUTOLOAD @ISA);
+our @ISA = ('Net::Bonjour::Entry');
+
+1;
Added: branches/upstream/libnet-bonjour-perl/current/t/1-use.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/t/1-use.t?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/t/1-use.t (added)
+++ branches/upstream/libnet-bonjour-perl/current/t/1-use.t Tue Sep 1 00:44:22 2009
@@ -1,0 +1,3 @@
+use Test::More tests => 1;
+
+BEGIN { use_ok('Net::Bonjour') };
Added: branches/upstream/libnet-bonjour-perl/current/t/2-entry.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/t/2-entry.t?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/t/2-entry.t (added)
+++ branches/upstream/libnet-bonjour-perl/current/t/2-entry.t Tue Sep 1 00:44:22 2009
@@ -1,0 +1,26 @@
+#!/usr/bin/perl -w
+use Test::More tests => 18;
+
+BEGIN { use_ok('Net::Bonjour') };
+
+use strict;
+use Net::DNS;
+
+my $entry;
+ok( $entry = Net::Bonjour::Entry->new(), 'constructor');
+ok( $entry->fqdn('server._test._tcp.local'), 'fqdn set');
+ok( $entry->fqdn eq 'server._test._tcp.local', 'fqdn get');
+ok( $entry->name('server.local'), 'name set');
+ok( $entry->name eq 'server.local', 'name get');
+ok( $entry->port('1234'), 'port set');
+ok( $entry->port == 1234, 'port get');
+ok( $entry->hostname('server.local'), 'hostname set');
+ok( $entry->hostname eq 'server.local', 'hostname get');
+ok( $entry->address('127.0.0.1'), 'address set');
+ok( $entry->address eq '127.0.0.1', 'address get');
+ok( $entry->attribute('text1', 'value'), 'attribute set');
+ok( $entry->attribute('text1') eq 'value', 'attribute get');
+ok( $entry->all_attrs, 'attribute reload');
+ok( $entry->dnsrr, 'dnsrr PTR');
+ok( $entry->dnsrr('srv'), 'dnsrr SRV');
+ok( $entry->dnsrr('txt'), 'dnsrr TXT');
Added: branches/upstream/libnet-bonjour-perl/current/t/3-rendezvous.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/t/3-rendezvous.t?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/t/3-rendezvous.t (added)
+++ branches/upstream/libnet-bonjour-perl/current/t/3-rendezvous.t Tue Sep 1 00:44:22 2009
@@ -1,0 +1,26 @@
+#!/usr/bin/perl -w
+use Test::More tests => 18;
+
+BEGIN { use_ok('Net::Rendezvous') };
+
+use strict;
+use Net::DNS;
+
+my $entry;
+ok( $entry = Net::Rendezvous::Entry->new(), 'constructor');
+ok( $entry->fqdn('server._test._tcp.local'), 'fqdn set');
+ok( $entry->fqdn eq 'server._test._tcp.local', 'fqdn get');
+ok( $entry->name('server.local'), 'name set');
+ok( $entry->name eq 'server.local', 'name get');
+ok( $entry->port('1234'), 'port set');
+ok( $entry->port == 1234, 'port get');
+ok( $entry->hostname('server.local'), 'hostname set');
+ok( $entry->hostname eq 'server.local', 'hostname get');
+ok( $entry->address('127.0.0.1'), 'address set');
+ok( $entry->address eq '127.0.0.1', 'address get');
+ok( $entry->attribute('text1', 'value'), 'attribute set');
+ok( $entry->attribute('text1') eq 'value', 'attribute get');
+ok( $entry->all_attrs, 'attribute reload');
+ok( $entry->dnsrr, 'dnsrr PTR');
+ok( $entry->dnsrr('srv'), 'dnsrr SRV');
+ok( $entry->dnsrr('txt'), 'dnsrr TXT');
Added: branches/upstream/libnet-bonjour-perl/current/t/4-enterprise.ot
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-bonjour-perl/current/t/4-enterprise.ot?rev=43354&op=file
==============================================================================
--- branches/upstream/libnet-bonjour-perl/current/t/4-enterprise.ot (added)
+++ branches/upstream/libnet-bonjour-perl/current/t/4-enterprise.ot Tue Sep 1 00:44:22 2009
@@ -1,0 +1,16 @@
+use Test::More tests => 9;
+
+BEGIN { use_ok('Net::Bonjour') };
+
+use strict;
+
+my $res;
+ok( $res = Net::Bonjour->new, 'constructor');
+ok( $res->service('http'), 'service set');
+ok( $res->domain('zeroconf.org'), 'domain set');
+ok( $res->domain eq 'zeroconf.org', 'domain get');
+ok( $res->fqdn eq '_http._tcp.zeroconf.org', 'fqdn get');
+ok( $res->discover, 'discover');
+my @entries;
+ok( @entries = sort( {$a->name cmp $b->name} $res->entries), 'entries');
+ok( $#entries > -1, 'entry count');
More information about the Pkg-perl-cvs-commits
mailing list