File Coverage

blib/lib/Device/GPIB/Prologix.pm

Criterion	Covered	Total	%
statement	6	176	3.4
branch	0	70	0.0
condition			n/a
subroutine	2	33	6.0
pod	27	30	90.0
total	35	309	11.3

# Prologix.pm

# Author: Mike McCauley ([e-mail]),
# Copyright (C) AirSpayce Pty Ltd
# $Id: $

package Device::GPIB::Prologix;

use strict;
use Device::SerialPort;

$Device::GPIB::Prologix::VERSION = '0.04';
$Device::GPIB::Prologix::debug = 0;

sub new
{
    my ($class, $port) = @_;

    my $self = {};
    bless $self, $class;

    # Defaults:
    $self->{Port} = '/dev/ttyUSB0';
    $self->{Baudrate} = '9600';
    $self->{Databits} = '8';
    $self->{Parity} = 'n';
    $self->{Stopbits} = '1';
    $self->{Handshake} = 'rts';
    $self->{ReadCharTimeout} = 2000; # ms

    $self->{Port} = $port if defined $port;

    my ($portname, $baudrate, $databits, $parity, $stopbits, $handshake)
	= split(/:/, $self->{Port});
    $self->{Baudrate}  = $baudrate  if defined $baudrate;
    $self->{Databits}  = $databits  if defined $databits;
    $self->{Parity}    = $parity    if defined $parity;
    $self->{Stopbits}  = $stopbits  if defined $stopbits;
    $self->{Handshake} = $handshake if defined $handshake;

    debug("$class is connecting to $portname with $self->{Databits}:$self->{Parity}:$self->{Stopbits}:$self->{Handshake}");

    $self->{serialport} = new Device::SerialPort($portname);
    if (!$self->{serialport})
    {
	warning("Could not open serial port $portname: $!");
	return;
    }
    $self->{serialport}->baudrate($self->{Baudrate});
    $self->{serialport}->databits($self->{Databits});
    $self->{serialport}->parity($self->{Parity});
    $self->{serialport}->stopbits($self->{Stopbits});
    $self->{serialport}->handshake($self->{Handshake});
    $self->{serialport}->read_char_time($self->{ReadCharTimeout});
    $self->{serialport}->read_const_time(0);
    $self->{serialport}->stty_icanon(0);

    return unless $self->initialised();

    return $self;
}

sub initialised
{
    my ($self) = @_;

    return unless $self->version() =~ /^Prologix/;
    # Set the Prologix into a state we like
    $self->auto(0);
    return unless $self->auto() == 0;

    return 1; # OK
}

sub send
{
    my ($self, $s) = @_;

    debug("Sending: '$s'");

    # TODO:
    # Escape $s, prepend CR, LF or ESC with ESC
    $self->{serialport}->write($s);
    $self->{serialport}->write("\n"); # Trigger transmission
}

sub read_to_timeout
{
    my ($self) = @_;

    my $buf;
    while (1)
    {
	my ($count, $ch) = $self->{serialport}->read(1);
	my $x = unpack('H*', $ch);
	debug("got $count, $ch: $x");
	return $buf
	    unless $count;
	$buf .= $ch;
    }
}

sub read_to_eol
{
    my ($self) = @_;

    my $buf;
    while (1)
    {
	my ($count, $ch) = $self->{serialport}->read(1);
	if ($count)
	{
	    my $x = unpack('H*', $ch);
	    debug("got $count, $ch: $x");
	    if ($ch eq "\r")
	    {
		# ignore CR
	    }
	    elsif ($ch eq "\n")
	    {
		# NL, end of message (unless we are reading binary)
		last;
	    }
	    else
	    {
		$buf .= $ch;
	    }
	}
	else
	{
	    last;
	}
    }

    # Got a buffer full
    debug("Read: '$buf'");
    return $buf;
}

sub read
{
    my ($self, $eoi) = @_;

    my $cmd = '++read';
    $cmd .= ' eoi'
	if defined($eoi);
    $self->send($cmd);
    return $self->read_to_eol();
}

sub read_binary
{
    my ($self) = @_;

    $self->send('++read eoi');
    return $self->read_to_timeout();
}

sub warning
{
    my ($s) = @_;

    print "WARNING: $s\n";
}

sub debug
{
    my ($s) = @_;

    print "DEBUG: $s\n"
	if $Device::GPIB::Prologix::debug;
}

sub close
{
    my ($self) = @_;

    if ($self->{serialport})
    {
	$self->{serialport}->close();
	undef $self->{serialport};
    }
}

sub DESTROY
{
    my ($self) = @_;

    $self->close();
}

###
### Implementations of low level Prologix commands
###

sub version
{
    my ($self) = @_;

    # Send the command
    $self->send('++ver');
    # Read the result
    return $self->read_to_eol();
}

sub auto
{
    my ($self, $value) = @_;

    if (defined($value))
    {
	$self->send("++auto $value");
	return;
    }
    else
    {
	$self->send("++auto");
	return $self->read_to_eol();
    }
}

sub addr
{
    my ($self, $addr, $sad) = @_;

    if (defined($addr))
    {
	my $cmd = "++addr $addr";
	$cmd .= " $sad"
	    if defined $sad;
	$self->send($cmd);
	return;
    }
    else
    {
	$self->send('++addr');
	return $self->read_to_eol();
    }
}

sub clr
{
    my ($self) = @_;

    $self->send('++clr');
}

sub eoi
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++eoi ' . $val ? '1' : '0');
	return;
    }
    else
    {
	$self->send('++eoi');
	return $self->read_to_eol();
    }
}

sub eos
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send("++eos $val");
	return;
    }
    else
    {
	$self->send('++eos');
	return $self->read_to_eol();
    }
}

sub eot_enable
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++eot_enable ' . $val ? '1' : '0');
	return;
    }
    else
    {
	$self->send('++eot_enable');
	return $self->read_to_eol();
    }
}

sub eot_char
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++eot_char ' . ord($val));
	return;
    }
    else
    {
	$self->send('++eot_char');
	return $self->read_to_eol();
    }
}

sub ifc
{
    my ($self) = @_;

    $self->send('++ifc');
}

sub llo
{
    my ($self) = @_;

    $self->send('++llo');
}

sub loc
{
    my ($self) = @_;

    $self->send('++loc');
}

sub lon
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++lon ' . $val ? '1' : '0');
	return;
    }
    else
    {
	$self->send('++lon');
	return $self->read_to_eol();
    }
}

sub mode
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++mode ' . $val ? '1' : '0');
	return;
    }
    else
    {
	$self->send('++mode');
	return $self->read_to_eol();
    }
}

sub read_tmo_ms
{
    my ($self, $val) = @_;

    $self->send('++read_tmo_ms ' . int($val));
}

sub rst
{
    my ($self) = @_;

    $self->send('++rst');
}

sub savecfg
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++savecfg ' . $val ? '1' : '0');
	return;
    }
    else
    {
	$self->send('++savecfg');
	return $self->read_to_eol();
    }
}

sub spoll
{
    my ($self, $addr, $sad) = @_;

    my $cmd = 'spoll';
    $cmd .= " $addr"
	if defined($addr);
    $cmd .= " $sad"
	if defined($sad);
    $self->send($cmd);
}

sub srq
{
    my ($self) = @_;

    $self->send('++srq');
    return $self->read_to_eol();
}

sub status
{
    my ($self, $val) = @_;

    if (defined($val))
    {
	$self->send('++status ' . $val);
	return;
    }
    else
    {
	$self->send('++status');
	return $self->read_to_eol();
    }
}

sub trg
{
    my ($self, @addrs) = @_;

    my $cmd = '++trg';
    while (@addrs)
    {
	$cmd .+ ' ' . shift(@addrs);
    }
    $self->send($cmd);
}


1;

__END__