#!/usr/bin/perl -wT

package Net::Services;

#=============================================================================
#
# $Id: Services.pm,v 0.01 2001/10/21 19:40:42 mneylon Exp $
# $Revision: 0.01 $
# $Author: mneylon $
# $Date: 2001/10/21 19:40:42 $
# $Log: Services.pm,v $
# Revision 0.01  2001/10/21 19:40:42  mneylon
# Initial Release to Perlmonks
#
#
#=============================================================================

use strict;
use warnings;

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT %EXPORT_TAGS);
    $VERSION     = sprintf( "%d.%02d", q($Revision: 0.01 $) =~ /\s(\d+)\.(\d+)/ );
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    %EXPORT_TAGS = ( );
}



# Constructor; call to rebuild() when completed.

sub new { 
	my $proto = shift;
	my $class = ref( $proto ) || $proto;

	my $self = { 
		services => [] 
	};
	bless $self, $class;
	$self->rebuild();
	return $self;
}


# Rebuilds the services list using standard system calls

sub rebuild {
	my $self = shift;
	my @services;

	setservent( 1 );	# Start polling, get only desired prototypes
	while ( my @data = getservent() ) 
	{
		push @services, \@data;
	}
	endservent();
	$self->{ services } = \@services;

	# A cache to improve lookups
	my %cache;
	my $i = 0;
	foreach my $service ( @services ) {
		push @{$cache{ $service->[ 2 ] }}, $i;  # by port...
		push @{$cache{ $service->[ 0 ] }}, $i;  # by name...
		foreach my $alias ( split /\s*/, $service->[1] ) {
			push @{$cache{ $alias } }, $i;
		}
		$i++;
	}
	$self->{ cache } = \%cache;
	return 1;
}

# Returns the services information for a given port or service name
sub get_service_info {
	my $self = shift;
	my $key = shift;
	my $protocol = lc(shift) || 'tcp';

	# Look for 'dddd/ccc' formats in the key , and work with appropriate
	if ( $key =~ /^(\d*)\/(\w*)$/ ) {
		$key = $1;
		$protocol = $2;
	}
	
	if ( exists $self->{ cache }->{ $key } ) {
		foreach my $index ( @{ $self->{ cache }->{ $key } } ) {
			my ( $name, $aliases, $port, $proto ) = 
			    @{ $self->{ services }->[ $index ] };
			if ( $proto eq $protocol ) {
				return ( $name, $aliases, $port, $proto )
			} else { next; }
		}
	}
	return undef;
}

sub get_services {
	my $self = shift;
	my $key = shift;
	my $protocol = lc( shift )  || 'tcp';

	# Look for 'dddd/ccc' formats in the key , and work with appropriate
	if ( $key =~ /^(\d*)\/(\w*)$/ ) {
		$key = $1;
		$protocol = $2;
	}

	my @services;
	if ( exists $self->{ cache }->{ $key } ) {
		foreach my $index ( @{ $self->{ cache }->{ $key } } ) {
			my @data = 
			    @{ $self->{ services }->[ $index ] };
			if ( $data[-1] eq $protocol ) {
				push @services, \@data;
			} else { next; }
		}
		return @services;
	}
	return undef;
}

# Now some functions to access specific data from the list above
sub get_service_port {
	my $self = shift;
	if ( my @service = $self->get_service_info( @_ ) ) {
		return $service[2];
	} else {
		return undef;
	}
}

sub get_service_name {
	my $self = shift;
	if ( my @service = $self->get_service_info( @_ ) ) {
		return $service[0];
	} else {
		return undef;
	}
}

sub get_service_aliases {
	my $self = shift;
	if ( my @service = $self->get_service_info( @_ ) ) {
		return split /\s*/, $service[1];  # Split aliases up nicely
	} else {
		return undef;
	}
}

sub get_service_protocol {
	my $self = shift;
	if ( my @service = $self->get_service_info( @_ ) ) {
		return $service[3];
	} else {
		return undef;
	}
}

sub get_all_services { 
	my $self = shift;
	my $proto = shift;

	my @services;
	foreach my $service ( @{ $self->{ services } } ) {
		my @data = @$service;
		if ( $proto && $data[-1] eq $proto ) {
			push @services, \@data;
		}
	}
	return @services;
}

sub get_all_ports { 
	my $self = shift;
	my $proto = shift;

	my @ports;
	foreach my $service ( @{ $self->{ services } } ) {
		my @data = @$service;
		if ( $proto && $data[-1] eq $proto ) {
			push @ports, $data[2];
		}
	}
	return @ports;
}

sub get_all_names {
	my $self = shift;
	my $proto = shift;

	my @names;
	foreach my $service ( @{ $self->{ services } } ) {
		my @data = @$service;
		if ( $proto && $data[-1] eq $proto ) {
			push @names, $data[0];
		}
	}
	return @names;
}


1;
__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

Net::Services - Quick access to ports and service information

=head1 SYNOPSIS

  use Net::Services;
  my $services = new Net::Services;

  my ( $name, $aliases, $port, $protocall ) = 
	$services->get_service_info( 80 );

  my $www_port = $services->get_service_port( 'www' );
  my $service_name = $services->get_service_name( '21/tcp' );

  my @exec_ports = grep { $_ < 1024 } $services->get_all_ports( 'tcp' );

=head1 DESCRIPTION

Net::Services provides quick access to the OS's description of ports 
and services, normally available to perl by the use of C<getservent()> and 
other related functions.  While these functions are sufficiently easy to
use, it does require the OS to run through it's internal database of 
service entries in order to locate them.  Net::Services caches these
values upon creation (along with the ability to rebuild this at any time)
as to help speed up the process.

Note that because multiple possible services exist for a given port
or name (eg many-to-many relationships), the functions here that return
a single service behave as C<getservent()> and friends do, by returning
the first service in the database with that port or name.  Other 
functions are available to enumerate across all possible ports if
needed.

Also note that unless otherwise specified, the services are returned
for the 'tcp' protocol.   In most cases, you can specify a different 
protocol to be returned.

=over

=item C<new>

Creates a new Net::Services object.  The services cache is built at this 
time.

=item C<rebuild>

Rebuilds the services cache.  While the OS's services database is 
typcially static until a reboot, it may change by the installation 
of new software or the editing of files (such as C</etc/services> for 
UNIX).  

=item C<get_service_info> ( <port|name|alias>, [<protocol>] )

Returns the first services information as an array that is associated with 
either the numerical port or textual name or alias.  Additionally, one may 
use  'number/protocol' format (i.e. '80/tcp').  The protocol is optional, 
but defaults to 'tcp' if not otherwise specified.  The order of the 
returned information is the same as with C<getservent()>, that is, 
name, aliases, port, and protocol.  Returns undef if no service is found
at the given port or with the given name or alias.

=item C<get_service> ( <port|name|alias>, [<protocol>] )

Similar to C<get_service_info>, but returns all services as an array of
arrays that are at that port or with that name or alias.

=item C<get_service_name> ( <port|name|alias>, [<protocol>] )
=item C<get_service_aliases> ( <port|name|alias>, [<protocol>] )
=item C<get_service_port> ( <port|name|alias>, [<protocol>] )
=item C<get_service_protocol> ( <port|name|alias>, [<protocol>] )

Similar to C<get_service_info>, but returns the specific data field
requested (name, aliases, port, protocol).  Note that in the case of 
aliases, this is returned as an array of the alias strings.

=item C<get_all_services> ( [<protocol>] )

Returns an array of arrays containing all services in the cache.  The
order is unspecified.  If the protocol is specified, entries are limited
to only that protocol type.

=item C<get_all_ports> ( [<protocol>] )
=item C<get_all_names> ( [<protocol>] ) 

Returns a list of all ports or names known to the cache; if protocol
is specified, the list is limited to only those services with that
protocol.  Note that because it's possible to have a many-to-many mapping
of ports and names, there may be duplicates on this list.  

=back

=head1 AUTHOR

Michael K. Neylon <lt>mneylon-pm@masemware.com<gt>

=head1 SEE ALSO

L<Net::servent>

=cut