File Coverage

blib/lib/Device/GPIB/Prologix.pm

Criterion	Covered	Total	%
statement	6	190	3.1
branch	0	86	0.0
condition	0	3	0.0
subroutine	2	35	5.7
pod	28	32	87.5
total	36	346	10.4

# 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.06';
$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);

    $self->{CurrentAddress} = -1;

    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 sendTo($$)
{
    my ($self, $s, $addr) = @_;

    $self->addr($addr) if defined $addr;
    $self->send($s);
}

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;  # Timeout
	$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 ';' && $self->{EOIMode}) # Experimental
	    {
		# Not EOI/LF mode, so this is the last char
		last;
	    }
	    elsif ($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;
}

# REad until a char or timeout.
# $waitfor can be either 'eoi' or the decimal number of the char < 256
sub read_until_timeout_or($$)
{
    my ($self, $waitfor) = @_;

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

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

    $self->addr($addr) if defined $addr;
    return $self->read_until_timeout_or('eoi'); # Only works if EOI is enabled
}

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

    $self->addr($addr) if defined $addr;
    $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))
    {
	if ($addr != $self->{CurrentAddress})
	{
	    my $cmd = "++addr $addr";
	    $cmd .= " $sad"
		if defined $sad;
	    $self->send($cmd);
	    $self->{CurrentAddress} = $addr;
	    return;
	}
    }
    else
    {
	$self->send('++addr');
	return $self->read_to_eol();
    }
}

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

    $self->addr($addr) if defined $addr;
    $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, $addr) = @_;

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

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

    $self->addr($addr) if defined $addr;
    $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__