File Coverage

blib/lib/Config/Hosts.pm

Criterion	Covered	Total	%
statement	175	205	85.3
branch	53	80	66.2
condition	22	35	62.8
subroutine	13	13	100.0
pod	10	10	100.0
total	273	343	79.5

package Config::Hosts;

use warnings;
use strict;

use Regexp::IPv6 qw($IPv6_re);

=head1 NAME

Config::Hosts - Interface to /etc/hosts file

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.03';

our $DEFAULT_FILE = '/etc/hosts';

our $TYPE_IP   =  1;
our $TYPE_HOST = -1;

=head1 SYNOPSIS

Config::Hosts - Interface to /etc/hosts file. A tool that manages the
hosts list on a machine, is able to query/insert/delete/update the
entries by IP or by a hostname, and also maintains the original
comments and some sanity checks on IP and hostname values.

    use Config::Hosts;

    my $hosts = Config::Hosts->new();
	$hosts->read_hosts(); # reads default /etc/hosts
	$hosts->query_host($host_or_ip);
	$hosts->insert_host(ip => $ip, hosts => [qw(host1 host2)]);
	$hosts->update_host($ip, hosts=> [qw(host1 host3)]);
	$hosts->delete_host('host3');
	$hosts->write_hosts("/tmp/hosts");

=head1 EXPORT

The interface is entirely object-oriented. The following methods have
been defined:

=head1 SUBROUTINES/METHODS

=head2 new ($;%)

The constructor. Accepts optional hash with one key only: file - the
name of the file as alternative to default /etc/hosts.

Returns the newly blessed object.

=cut

sub new ($;@) {

	my $class = shift;
	my %params = @_;

	my $self = {};
	$self->{_file} = $params{file} || $DEFAULT_FILE;
	bless $self, $class;

	return $self;
}

=head2 is_valid_ip ($)

internal utility function to check whether the IP given is a valid
IPv4 or IPv6 address. Returns 1 or 0, naturally.

=cut

sub is_valid_ip ($) {

	my $ip = shift;
	if ($ip =~ /^$IPv6_re$/) {
		return 1;
	}
	return $ip =~
		/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ && ($1+0 | $2+0 | $3+0 | $4+0) < 0x100 ?
		1 : 0;
}

=head2 is_valid_host($)

Internal utility to determine whether the host name is a valid
hostname as required by /etc/hosts manual.

=cut

sub is_valid_host ($) {

	my $host = shift;
	return $host =~
		/^[a-z]([a-z]|[0-9]|\-|\.)*([a-z]|[0-9])$/i ?
		1 : 0;
}

=head2 read_hosts($;$)

Read the host file into a data structure to later be used by the other
methods. Optional argument may be the file to read hosts table from.

=cut

sub read_hosts ($;$) {

	my $self = shift;
	my $hosts_file = shift || $self->{_file};

	my $contents = [];
	open(H, $hosts_file) or die "Couldn't open hosts file $hosts_file: $!";
	my $i = 0; my $l = 0;
	my $hosts = {};
	while () {
		chomp;
		$l++;
		if (! /\S/) {
			$contents->[$i] = $_;
		}
		elsif (/^\s*\#/) {
			$contents->[$i] = $_;
		}
		elsif (
			/^\s*(\d+\.\d+\.\d+\.\d+)\s+(\S.*)/ ||
			/^\s*(\S*\:\S*\:\S*)\s+(\S.*)/
		) {
			$_ = lc $_;
			$contents->[$i] = $_;
			my $ip = $1;
			my ($hosts_list, $comment) = split(/\#/, $2);
			$comment ||= "";
			if (!is_valid_ip($ip)) {
				print STDERR "Line $l: Warning: IP $ip is invalid\n";
			}
			my @hosts = split(/\s+/, $hosts_list);
			$contents->[$i] = $_;
			if ($hosts->{$ip}) {
				print STDERR "Line $l: Warning: duplicate IP entry $ip, the last one will be used\n";
			}
			$hosts->{$ip} = {
				hosts => [ @hosts ],
				comment => $comment,
				line => $i,
			};
			for my $host (@hosts) {
				if (! is_valid_host($host)) {
					print STDERR "Line $l: Warning: Host $host is invalid\n";
				}
				if ($hosts->{$host}) {
					print STDERR "Line $l: Warning: duplicate Host entry $host, the last one will be used\n";
				}
				$hosts->{$host} = {
					ip => $ip,
					comment => $comment,
					line => $i,
				}
			}
		}
		else {
			die "Invalid entry: $_\nBailing out.\n";
		}
		$i++;
	}
	$self->{_contents} = $contents;
	$self->{_hosts}    = $hosts;
}

=head2 determine_ip_or_host ($$)

Check whether the given argument is an IP, a HOST or neither. Returns
1, -1 or 0 correspondingly.

=cut

sub determine_ip_or_host ($$) {

	my $self      = shift;
	my $candidate = shift;

	return $TYPE_IP   if is_valid_ip($candidate);
	return $TYPE_HOST if is_valid_host($candidate);
	return  0;
}

=head2 query_host ($$)

Queries the read hosts table to find specified argument that may be IP
address or host name.

Returns hash containing the relevant entry if found or undef if not.

=cut

sub query_host ($$) {

	my $self = shift;
	my $host = shift;

	my $type = $self->determine_ip_or_host($host);
	if ($type) {
		return $self->{_hosts}{$host};
	}
	else {
		return undef;
	}
}

=head2 insert_host ($%)

Inserts a host. Both IP and hostnames must be specified as a hash.
Hostname may be a single scalar or arrayref of hostnames.

=cut

sub insert_host ($%) {

	my $self = shift;
	my %params = @_;

	if (! $params{ip} || ! $params{hosts}) {
		print STDERR "No ip or host supplied to insert_host, ignoring\n";
		return 0;
	}
	my $ip = $params{ip};
	if (! is_valid_ip($ip)) {
		print STDERR "Invalid IP $ip, ignoring\n";
		return 0;
	}
	my $hosts;
	if (! ref $params{hosts}) {
		$hosts = [ $params{hosts} ];
	}
	else {
		$hosts = $params{hosts};
	}
	if (ref $hosts ne 'ARRAY') {
		print STDERR "Host names must be scalar value or ARRAY ref, ignoring\n";
		return 0;
	}
	if (grep {
		!is_valid_host($_) &&
		print STDERR "Invalid host $_ passed, ignoring insert\n"
	} @{$hosts}) {
		return 0;
	}
	my $hosts_line = join(" ", @{$hosts});
	my $comment = $params{comment} ? " $params{comment}" : "";
	push(@{$self->{_contents}}, "$ip\t$hosts_line$comment");
	if ($self->{_hosts}{$ip}) {
		print STDERR "INSERT: Warning:duplicate IP $ip, the last one will be used\n";
		for my $h_host (@{$self->{_hosts}{$ip}{hosts}}) {
			delete $self->{_hosts}{$h_host}
		}
		my $index = $self->{_hosts}{$ip}{line};
		splice(@{$self->{_contents}}, $index, 1);
	}
	$self->{_hosts}{$ip} = {
		hosts => $hosts,
		comment => $comment,
		line => scalar @{$self->{_contents}},
	};
	for my $host (@{$hosts}) {
		if ($self->{_hosts}{$host}) {
			print STDERR "INSERT: Warning:duplicate Host entry $host, the last one will be used\n";
		}
		$self->{_hosts}{$host} = {
			ip => $ip,
			comment => $comment,
			line => scalar @{$self->{_contents}},
		}
	}
	return 1;
}

=head2 delete_host ($$)

Deletes an entry in hosts table. The entry is determined either by IP
or by hostname, all entries related to this host or IP are wiped out.

=cut

sub delete_host ($$) {

	my $self = shift;
	my $host = shift;

	my $type = $self->determine_ip_or_host($host);
	if (! $type) {
		print STDERR "Invalid host $host supplied\n";
		return 0;
	}
	if (! $self->{_hosts}{$host}) {
		print STDERR "No such host $host\n";
		return 0;
	}
	my $index = $self->{_hosts}{$host}{line};
	splice(@{$self->{_contents}}, $index, 1);
	if ($type == $TYPE_IP) {
		for my $h_host (@{$self->{_hosts}{$host}{hosts}}) {
			delete $self->{_hosts}{$h_host}
		}
		delete $self->{_hosts}{$host};
	}
	else {
		my $ip = $self->{_hosts}{$host}{ip};
		my $ip_hosts = $self->{_hosts}{$ip}{hosts};
		for my $h_host (@{$ip_hosts}) {
			delete $self->{_hosts}{$h_host}
		}
		delete $self->{_hosts}{$ip};
	}
	return 1;
}

=head2 update_host ($$)

Updates an entry in hosts table. Arguments should be of the following
format: $self->update_host($ip_or_host, ip => $new_ip, hosts => [
@new_hosts ]);

New hosts' argument may be a single scalar instead of arrayref.

=cut

sub update_host ($$%) {

	my $self   = shift;
	my $host   = shift;
	my %params = @_;

	my $type = $self->determine_ip_or_host($host);
	if (! $type) {
		print STDERR "Invalid host $host supplied\n";
		return 0;
	}
	if (! $self->{_hosts}{$host}) {
		print STDERR "No such host $host\n";
		return 0;
	}
	my $index = $self->{_hosts}{$host}{line};
	my $comment = $params{comment} ? " $params{comment}" : "";
	my $new_ip = $host;
	if ($params{ip} && !is_valid_ip($params{ip})) {
		print STDERR "Invalid argument IP given\n";
		return 0;
	}
	if ($params{hosts}) {
		if (! ref $params{hosts}) {
			$params{hosts} = [ $params{hosts} ];
		}
		if (ref $params{hosts} ne 'ARRAY') {
			print STDERR "New host names should be scalar value or array ref\n";
			return 0;
		}
		if (grep {
			!is_valid_host($_) &&
			print STDERR "Invalid host $_ passed, ignoring insert\n"
		} @{$params{hosts}}) {
			return 0;
		}
	}
	if ($type == $TYPE_IP && $params{ip}) {
		$new_ip = $params{ip};
		$self->{_hosts}{$new_ip} = delete $self->{_hosts}{$host};
		for my $h_host (@{$self->{_hosts}{$new_ip}{hosts}}) {
			$self->{_hosts}{$h_host}{ip} = $new_ip;
		}
	}
	if ($type == $TYPE_IP && $params{hosts}) {
		my @old_hosts = @{$self->{_hosts}{$new_ip}{hosts}};
		$self->{_hosts}{$new_ip}{hosts} = $params{hosts};
		for my $old_host (@old_hosts) {
			delete $self->{_hosts}{$old_host};
		}
		for my $new_host (@{$self->{_hosts}{$new_ip}{hosts}}) {
			$self->{_hosts}{$new_host} = {
				ip => $new_ip,
				comment => $comment,
				line => $self->{_hosts}{$new_ip}{line},
			}
		}
	}
	if ($type == $TYPE_HOST && $params{ip}) {
		my $old_ip = $self->{_hosts}{$host}{ip};
		$new_ip = $params{ip};
		for my $h_host (@{$self->{_hosts}{$old_ip}{hosts}}) {
			$self->{_hosts}{$h_host}{ip} = $new_ip;
		}
		$self->{_hosts}{$new_ip} = delete $self->{_hosts}{$old_ip};
	}
	if ($type == $TYPE_HOST && $params{hosts}) {
		$new_ip = $self->{_hosts}{$host}{ip};
		my @old_hosts = @{$self->{_hosts}{$new_ip}{hosts}};
		$self->{_hosts}{$new_ip}{hosts} = $params{hosts};
		for my $old_host (@old_hosts) {
			delete $self->{_hosts}{$old_host};
		}
		for my $new_host (@{$self->{_hosts}{$new_ip}{hosts}}) {
			$self->{_hosts}{$new_host} = {
				ip => $new_ip,
				comment => $comment,
				line => $self->{_hosts}{$new_ip}{line},
			}
		}
	}
	my $hosts_line = join(" ", @{$self->{_hosts}{$new_ip}{hosts}});
	my $new_line = "$new_ip\t$hosts_line$comment";
	splice(@{$self->{_contents}}, $index, 1, $new_line);

	return 1;
}

=head2 write_hosts($;$)

Writes the hosts table either to the default or to a specified (via
parameter) file.

=cut

sub write_hosts ($;$) {

	my $self = shift;
	my $hosts_file = shift || $self->{_file};

	open(F, ">$hosts_file") or die "Cannot write hosts file $hosts_file: $!";
	local $, = "\n";
	local $\ = "\n";
	print F @{$self->{_contents}};
	close F;
}

=head1 AUTHOR

Roman M. Parparov, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C
rt.cpan.org>, or through the web interface at
L.  I
will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.

CAVEAT: the changes in host table are not committed unless you
explicitly write_hosts() them.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Config::Hosts


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS

Thanks to Vicente Gavara C<<  >> for
providing a fix for editing/deleting routines.

=head1 LICENSE AND COPYRIGHT

Copyright 2011 Roman M. Parparov.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Config::Hosts