package Net::SAP; ################ # # SAP: Session Announcement Protocol (RFC2974) # # Nicholas J Humfrey # njh@cpan.org # use strict; use Carp; use Net::SAP::Packet; use Socket qw/ unpack_sockaddr_in /; use Socket6 qw/ inet_ntop inet_pton unpack_sockaddr_in6 /; use IO::Socket::Multicast6; use vars qw/$VERSION/; our $VERSION="0.10"; # User friendly names for multicast groups my %groups = ( 'ipv4'=> '224.2.127.254', 'ipv4-local'=> '239.255.255.255', 'ipv4-org'=> '239.195.255.255', 'ipv4-global'=> '224.2.127.254', 'ipv6-node'=> 'FF01::2:7FFE', 'ipv6-link'=> 'FF02::2:7FFE', 'ipv6-site'=> 'FF05::2:7FFE', 'ipv6-org'=> 'FF08::2:7FFE', 'ipv6-global'=> 'FF0E::2:7FFE', ); my $SAP_PORT = 9875; sub new { my $class = shift; my ($group) = @_; # Work out the multicast group to use croak "Missing group parameter" unless defined $group; if (exists $groups{$group}) { $group = $groups{$group}; } # Store parameters my $self = { 'group' => $group, 'port' => $SAP_PORT }; # Create Multicast Socket $self->{'socket'} = new IO::Socket::Multicast6( LocalAddr => $self->{'group'}, LocalPort => $SAP_PORT ) || return undef; # Set the TTL for transmitted packets $self->{'socket'}->mcast_ttl( 127 ); # Join the multicast group $self->{'socket'}->mcast_add( $self->{'group'} ) || die "Failed to join multicast group: $!"; bless $self, $class; return $self; } # # Returns the multicast group the socket is bound to # sub group { my $self = shift; return $self->{'group'}; } # # Sets the TTL for packets sent # sub ttl { my $self = shift; my ($ttl) = @_; # Set new TTL if specified if (defined $ttl) { return undef if ($ttl<0 or $ttl>127); $self->{'socket'}->mcast_ttl($ttl); } return $self->{'socket'}->mcast_ttl(); } # # Blocks until a valid SAP packet is received # sub receive { my $self = shift; my $sap_packet = undef; while(!defined $sap_packet) { # Receive a packet my $data = undef; my $from = $self->{'socket'}->recv( $data, 1500 ); die "Failed to receive packet: $!" unless (defined $from); next unless (defined $data and length($data)); # Create new packet object from the data we received $sap_packet = new Net::SAP::Packet( $data ); next unless (defined $sap_packet); # Correct the origin on Stupid packets ! if ($sap_packet->origin_address() eq '' or $sap_packet->origin_address() eq '0.0.0.0' or $sap_packet->origin_address() eq '1.2.3.4' ) { if (sockaddr_family($from)==AF_INET) { my ($from_port, $from_ip) = unpack_sockaddr_in( $from ); $from = inet_ntop( AF_INET, $from_ip ); } elsif (sockaddr_family($from)==AF_INET6) { my ($from_port, $from_ip) = unpack_sockaddr_in6( $from ); $from = inet_ntop( AF_INET6, $from_ip ); } else { warn "Unknown address family (family=".sockaddr_family($from).")\n"; } $sap_packet->origin_address( $from ); } } return $sap_packet; } sub send { my $self = shift; my ($packet) = @_; croak "Missing data to send." unless defined $packet; # If it isn't a packet object, turn it into one if (ref $packet eq 'Net::SDP') { my $data = $packet->generate(); $packet = new Net::SAP::Packet(); $packet->payload( $data ); } elsif (ref $packet ne 'Net::SAP::Packet') { my $data = $packet; $packet = new Net::SAP::Packet(); $packet->payload( $data ); } # Assemble and send the packet my $data = $packet->generate(); if (!defined $data) { warn "Failed to create binary packet."; return -1; } elsif (length $data > 1024) { warn "Packet is more than 1024 bytes, not sending."; return -1; } else { return $self->{'socket'}->mcast_send( $data, $self->{'group'}, $self->{'port'} ); } } sub close { my $self=shift; # Close the multicast socket $self->{'socket'}->close(); undef $self->{'socket'}; } sub DESTROY { my $self=shift; if (exists $self->{'socket'} and defined $self->{'socket'}) { $self->close(); } } 1; __END__ =pod =head1 NAME Net::SAP - Session Announcement Protocol (rfc2974) =head1 SYNOPSIS use Net::SAP; my $sap = Net::SAP->new( 'ipv6-global' ); my $packet = $sap->receive(); $sap->close(); =head1 DESCRIPTION Net::SAP allows receiving and sending of SAP (RFC2974) multicast packets over IPv4 and IPv6. =head2 METHODS =over 4 =item $sap = Net::SAP->new( $group ) The new() method is the constructor for the C class. You must specify the SAP multicast group you want to join: ipv4-local ipv4-org ipv4-global ipv6-node ipv6-link ipv6-site ipv6-org ipv6-global Alternatively you may pass the address of the multicast group directly. When the C object is created, it joins the multicast group, ready to start receiving or sending packets. =item $packet = $sap->receive() This method blocks until a valid SAP packet has been received. The packet is parsed, decompressed and returned as a C object. =item $sap->send( $data ) This method sends out SAP packet on the multicast group that the C object to bound to. The $data parameter can either be a C object, a C object or raw SDP data. Passing a C object gives the greatest control over what is sent. Otherwise default values will be used. If no origin_address has been set, then it is set to the IP address of the first network interface. Packets greater than 1024 bytes will not be sent. This method returns 0 if packet was sent successfully. =item $group = $sap->group() Returns the address of the multicast group that the socket is bound to. =item $ttl = $sap->ttl( [$value] ) Gets or sets the TTL of outgoing packets. =item $sap->close() Leave the SAP multicast group and close the socket. =back =head1 TODO =over =item add automatic detection of IPv6 origin address =item add method of choosing the network interface to use for multicast =item Packet decryption and validation =back =head1 SEE ALSO L, L, perl(1) L =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you will automatically be notified of progress on your bug as I make changes. =head1 AUTHOR Nicholas J Humfrey, njh@cpan.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2006 University of Southampton This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.005 or, at your option, any later version of Perl 5 you may have available. =cut