File Coverage

lib/Hardware/1Wire/HA7Net.pm

Criterion	Covered	Total	%
statement	56	247	22.6
branch	3	104	2.8
condition	1	6	16.6
subroutine	16	36	44.4
pod	5	5	100.0
total	81	398	20.3

package Hardware::1Wire::HA7Net;

use Exporter;
use LWP::UserAgent;
use strict;
use vars qw($VERSION @ISA);

$VERSION = '1.01';
@ISA = qw(Exporter);
my ($RCSVERSION) = '$Revision: 1.7 $ ' =~ /\$Revision:\s+([^\s]+)/;

##############################################################################
package Hardware::1Wire::HA7Net::Generic;

use Exporter;
use vars qw($VERSION @ISA);

@ISA = qw(Exporter);
$VERSION = $Hardware::1Wire::HA7Net::VERSION;

sub _new {
    my ($class, $ha7net, $address) = @_;
    my $family = substr($address, -2);

    return bless {
	ha7net	=> $ha7net,
	family	=> $family,
	address	=> $address,
	}, $class;
    }

sub isa {
    my ($self, $type) = @_;

    die "Cannot match empty type"	unless $type;
    for my $match (@{$self->{type}}) {
	return 1	if uc($type) eq $match;
	}
    return 0;
    }

sub ha7net { shift->{ha7net} }

sub family { shift->{family} }

sub address { shift->{address} }

sub units { shift->{units} }

sub type {
    my $self = shift;
    if (wantarray) {
	return @{ $self->{type} };
	}
    else {
	return $self->{type}[0];
	}
    }

sub part_of { shift->{part_of} }

##############################################################################
package Hardware::1Wire::HA7Net::DS1820;

use Exporter;
use vars qw($VERSION @ISA);

@ISA = qw(Hardware::1Wire::HA7Net::Generic);
$VERSION = $Hardware::1Wire::HA7Net::VERSION;

sub _new {
    my $class = shift;
    my $self = $class->SUPER::_new(@_);

    $self->{type} = [qw(DS1820 DS18S20 DS1920 1820 18S20 1920)];
    $self->{units} = "Degrees C";
    return $self;
    }


sub temperature {
    my $self = shift;
    my $response = $self->{ha7net}->{ua}->get($self->{ha7net}->{baseurl} .
	"1Wire/ReadTemperature.html?Address_Array=$self->{address}");
    return undef	unless $response->is_success;
    $response = $response->content;

    my @response = $response =~
	/ID="Address.*?VALUE="([\dA-F]+)"
		.*?
	 ID="Temperature.*?VALUE="(-?[\d.]+)"/x;

    if (wantarray) {
	return @response;
	}
    else {
	return $response[1];
	}
    }

##############################################################################
package Hardware::1Wire::HA7Net::DS18B20;

use Exporter;
use vars qw($VERSION @ISA);

@ISA = qw(Hardware::1Wire::HA7Net::Generic);
$VERSION = $Hardware::1Wire::HA7Net::VERSION;

sub _new {
    my $class = shift;
    my $self = $class->SUPER::_new(@_);

    $self->{resolution} = 12;
    $self->{type} = [qw(DS18B20 18B20)];
    $self->{units} = "Degrees C";
    return $self;
    }

sub resolution {
    my $self = shift;
    if (@_) {
	my $resolution = shift;
	die "Resolution out of range of 9..12 for DS18B20 $self->{address}"
	    if $resolution < 9 || $ resolution > 12;
	$self->{resolution} = $resolution;
	}
    return $self->{resolution};
    }

sub temperature {
    my $self = shift;
    my $response = $self->{ha7net}->{ua}->get($self->{ha7net}->{baseurl} .
	"1Wire/ReadDS18B20.html?DS18B20Request={$self->{address},$self->{resolution}}");
    return undef	unless $response->is_success;
    $response = $response->content;

    my @response = $response =~
	/ID="Address.*?VALUE="([\dA-F]+)"
		 .*?
	 ID="Temperature.*?VALUE="(-?[\d.]+)
		 .*?
	 ID="Resolution.*?VALUE="([\d]+\+?)"/x;

    if (wantarray) {
	return @response;
	}
    else {
	return $response[1];
	}
    }

##############################################################################
package Hardware::1Wire::HA7Net::Analog;

use Exporter;
use vars qw($VERSION @ISA);

@ISA = qw(Hardware::1Wire::HA7Net::Generic);
$VERSION = $Hardware::1Wire::HA7Net::VERSION;

sub _new {
    my $class = shift;
    my $self = $class->SUPER::_new(@_);

    my $response = $self->{ha7net}->{ua}->get($self->{ha7net}->{baseurl} .
	"1Wire/ReadAnalogProbe.html?Address_Array=$self->{address}")->content;

    my ($type, $units) = $response =~
	/ID="Probe_Type.*?VALUE="(\w+)"
		.*?
	 ID="Probe_Units.*?VALUE="(.*?)"/x;

    $self->{type} = [ $type ];
    $self->{units} = $units;
    return $self;
    }

sub value {
    my $self = shift;
    my $response = $self->{ha7net}->{ua}->get($self->{ha7net}->{baseurl} .
	"1Wire/ReadAnalogProbe.html?Address_Array=$self->{address}");
    return undef	unless $response->is_success;
    $response = $response->content;

    my @response = $response =~
	/ID="Probe_Address.*?VALUE="([\dA-F]+)"
		.*?
	 ID="Probe_Value.*?VALUE="(-?[\d.]+)"
		.*?
	 ID="Temperature_Address.*?VALUE="([\dA-F]+)"
		.*?
	 ID="Temperature.*?VALUE="(-?[\d.]+?)"/x;

    if (wantarray) {
	return @response;
	}
    else {
	return $response[1];
	}
    }

##############################################################################
package Hardware::1Wire::HA7Net;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    my ($scan, $response, $sensor);
    if (@_) {
	($self->{baseurl}, $scan) = @_;
	$self->{baseurl} =~ s#/*$#/#;
	}
    else {
	die "Cannot yet probe for HA7Net's";
	}

    $self->{ua} = new LWP::UserAgent;
    $self->{ua}->agent("$class/$VERSION");

    #
    # If we do not want to scan the device now, just fill in empty arrays and
    # return.  Otherwise, continue with scanning the devices.
    #.
    if (defined $scan && $scan == 0) {
	@{ $self->{sensors} } = ();
	%{ $self->{by_addr} } = ();
	return $self;
	}

    $response = $self->{ua}->get($self->{baseurl} .
	"1Wire/Search.html?ConditionalSearch=on");
    die "Cannot access $self->{baseurl}"	unless $response->is_success;

    ($self->{version}) = $response->content =~ /HA7Net: (\d+(\.\d+)+)/;

    for my $addr ($response->content =~ /ID="ADDRESS.*?VALUE="([\dA-F]+)"/g) {
	if ($addr =~ /10$/) {
	    $sensor = _new Hardware::1Wire::HA7Net::DS1820 ($self, $addr);
	    }
	elsif ($addr =~ /28$/) {
	    $sensor = _new Hardware::1Wire::HA7Net::DS18B20 ($self, $addr);
	    }
	elsif ($addr =~ /12$/) {
	    $sensor = _new Hardware::1Wire::HA7Net::Analog ($self, $addr);
	    }
	push @{ $self->{sensors} }, $sensor;
	$self->{by_addr}->{$sensor->{address}} = $sensor;
	}

    _generate_associated_addresses($self);
    return $self;
    }

sub scan {
    my $self = shift;
    my ($response, $sensor, %by_addr, @new);

    @{ $self->{sensors} } = ();
    %by_addr = %{ $self->{by_addr} };
    %{ $self->{by_addr} } = ();

    $response = $self->{ua}->get($self->{baseurl} .
	"1Wire/Search.html?ConditionalSearch=on");

    for my $addr ($response->content =~ /ID="ADDRESS.*?VALUE="([\dA-F]+)"/g) {
	unless ($sensor = delete $by_addr{$addr}) {
	    if ($addr =~ /10$/) {
		$sensor = _new Hardware::1Wire::HA7Net::DS1820 ($self, $addr);
		}
	    elsif ($addr =~ /28$/) {
		$sensor = _new Hardware::1Wire::HA7Net::DS18B20 ($self, $addr);
		}
	    elsif ($addr =~ /12$/) {
		$sensor = _new Hardware::1Wire::HA7Net::Analog ($self, $addr);
		}
	    push @new, $sensor;
	    }
	push @{ $self->{sensors} }, $sensor;
	$self->{by_addr}->{$sensor->{address}} = $sensor;
	}

    _generate_associated_addresses($self);

    if (defined $_[0]) {
	if (ref $_[0] eq "ARRAY") {
	    @{ $_[0] } = @new;
	    }
	else {
	    $_[0] = \@new;
	    }
	}
    if (defined $_[1]) {
	if (ref $_[1] eq "ARRAY") {
	    @{ $_[1] } = values %by_addr;
	    }
	else {
	    $_[1] = [ values %by_addr ];
	    }
	}
    return (@new + values %by_addr);	# Number of (existence of) changes
    }

#
# Find the addresses of the Temperature sensor in the analog sensors.  Not
# to be called externally.
#
sub _generate_associated_addresses {
    my $self = shift;
    my $response;

    ANALOG: for my $addr (keys %{ $self->{by_addr} }) {
	my $assoc_addr;
	next unless $addr =~ /12$/;
	for my $chk (values %{ $self->{by_addr} }) {
	    no warnings;
	    next ANALOG if $chk->{part_of} == $self->{by_addr}->{$addr};
	    }
	$response = $self->{ua}->get($self->{baseurl} .
	    "1Wire/ReadAnalogProbe.html?Address_Array=$addr")->content;
	($assoc_addr) =
	    $response =~ /ID="Temperature_Address.*?VALUE="([\dA-F]+)"/;
	$self->{by_addr}->{$assoc_addr}->{part_of} = $self->{by_addr}->{$addr};
	}
    }

sub sensors {
    @{ shift->{sensors} }
    }

sub read {
    my $self = shift;
    my (@objs, @ds1820, @ds18b20, @analog, %analog_objs, $response,
	$sensor, $sub, @answer, @results);

    #
    # Read everything by default, else read the set specified by the caller
    #
    @_ = @{$self->{sensors}} unless @_;
    #
    # First, convert all request entities to objects, preparing for batched
    # reads.  If there is no object associated with a particular address,
    # create the object (which means reading it).  We exclude those from a
    # second scan, of course.  If there are any previously unknown sensors,
    # there will be @results, so we'll have to _generate_associated_addresses
    #
    for my $addr (@_) {
	if (ref($addr) =~ /^Hardware::1Wire::HA7Net::/) {
	    push @objs, $addr;
	    }
	elsif (ref($addr)) {
	    die "Cannot use read on a non Hardware::1Wire::HA7Net:: object";
	    }
	elsif ($addr !~ /^[\dA-Fa-f]{16}/) {
	    die "Illegal Dalls Semiconductor device address";
	    }
	elsif (exists $self->{by_addr}->{$addr}) {
	    push @objs, $self->{by_addr}->{$addr};
	    }
	else {
	    #
	    # Add a new device!
	    #
	    if ($addr =~ /10$/) {
		$response = $self->{ua}->get($self->{baseurl} .
		    "1Wire/ReadTemperature.html?Address_Array=$addr")->content;
		if (@answer = $response =~
		    /ID="Address.*?VALUE="([\dA-F]+)"
			    .*?
		     ID="Temperature.*?VALUE="(-?[\d.]+)"/gx) {
		    $sensor = _new Hardware::1Wire::HA7Net::DS1820 ($self, $addr);
		    }
		else {
		    warn "Cannot read device at address $addr";
		    }
		}
	    elsif ($addr =~ /28$/) {
		$response = $self->{ua}->get($self->{baseurl} .
		    "1Wire/ReadDS18B20.html?DS18B20Request={$addr,12}")->content;

		if (@answer = $response =~
		    /ID="Address.*?VALUE="([\dA-F]+)"
			     .*?
		     ID="Temperature.*?VALUE="(-?[\d.]+)/gx) {
		    $sensor = _new Hardware::1Wire::HA7Net::DS18B20 ($self, $addr);
		    }
		else {
		    warn "Cannot read device at address $addr";
		    }
		}
	    elsif ($addr =~ /12$/) {
		$response = $self->{ua}->get($self->{baseurl} .
		    "1Wire/ReadAnalogProbe.html?Address_Array=$addr")->content;

		if (@answer = $response =~
		    /ID="Probe_Address.*?VALUE="([\dA-F]+)"
			    .*?
		     ID="Probe_Value.*?VALUE="(-?[\d.]+)"
			    .*?
		     ID="Temperature_Address.*?VALUE="([\dA-F]+)"
			    .*?
		     ID="Temperature.*?VALUE="(-?[\d.]+?)"/gx) {
		    $sensor = _new Hardware::1Wire::HA7Net::Analog ($self, $addr);
		    #
		    # Analog devices have a temperature sensor associated
		    # with them - create that device, too (and enter it here)
		    #
		    if ($answer[2] =~ /10$/) {
			$sub = _new Hardware::1Wire::HA7Net::DS1820 ($self, $answer[2]);
			}
		    elsif ($answer[2] =~ /28$/) {
			$sub = _new Hardware::1Wire::HA7Net::DS18B20 ($self, $answer[2]);
			}
		    else {
			die "Unknown co-sensor associated with $addr";
			}
		    push @{ $self->{sensors} }, $sub;
		    $self->{by_addr}->{$sub->{address}} = $sub;
		    }
		else {
		    warn "Cannot read device at address $addr";
		    }
		}
	    else {
		die "Unknown sensor type $addr";
		}
	    if (@answer) {
		push @{ $self->{sensors} }, $sensor;
		$self->{by_addr}->{$sensor->{address}} = $sensor;
		push @results, @answer;
		}
	    }
	}
    _generate_associated_addresses($self)	if @results;
    #
    #
    # Next find all the analog sensors in the set of addresses given
    #
    for my $sensor (@objs) {
	if ($sensor->{ha7net} != $self) {
	    warn "Cannot read sensor from a different HA7Net";
	    next;
	    }
	if ($sensor->isa("hmp2001s")) {
	    push @analog, $sensor->{address};
	    $analog_objs{$sensor}++;
	    }
	}
    #
    # Then find all the  temperature sensors, eliminating those that would
    # be read by the analog read routine (so we don't read them twice)
    #
    for my $sensor (@objs) {
	if ($sensor->{ha7net} != $self) {
	    warn "Cannot read sensor from a different HA7Net";
	    next;
	    }
	if ($sensor->isa("ds1820")) {
	    no warnings;	# Otherwise the "unless" will elicit them
	    push @ds1820, $sensor->{address}
		unless $analog_objs{$sensor->part_of};
	    }
	elsif ($sensor->isa("ds18b20")) {
	    no warnings;	# Otherwise the "unless" will elicit them
	    push @ds18b20, "{$sensor->{address},$sensor->{resolution}}"
		unless $analog_objs{$sensor->part_of};
	    }
	}
    #
    # Now actually read the devices
    #
    if (@ds1820) {
	$response = $self->{ua}->get($self->{baseurl} .
	    "1Wire/ReadTemperature.html?Address_Array=" .
	    join ",", @ds1820)->content;
	push @results, $response =~
	    /ID="Address.*?VALUE="([\dA-F]+)"
		    .*?
	     ID="Temperature.*?VALUE="(-?[\d.]+)"/gx;
	}
    if (@ds18b20) {
	$response = $self->{ua}->get($self->{baseurl} .
	    "1Wire/ReadDS18B20.html?DS18B20Request=" .
	    join ",", @ds18b20)->content;

	push @results, $response =~
	    /ID="Address.*?VALUE="([\dA-F]+)"
		     .*?
	     ID="Temperature.*?VALUE="(-?[\d.]+)/gx;
	}
    if (@analog) {
	$response = $self->{ua}->get($self->{baseurl} .
	    "1Wire/ReadAnalogProbe.html?Address_Array=" .
	    join ",", @analog)->content;

	push @results, $response =~
	    /ID="Probe_Address.*?VALUE="([\dA-F]+)"
		    .*?
	     ID="Probe_Value.*?VALUE="(-?[\d.]+)"
		    .*?
	     ID="Temperature_Address.*?VALUE="([\dA-F]+)"
		    .*?
	     ID="Temperature.*?VALUE="(-?[\d.]+?)"/gx;
	}

    return @results;
    }

sub version { shift->{version} }

1;

__END__