################################################################################
package MGPIB;
################################################################################
# Provides a class for communicating with a GPIB server
#   by Michael Siegenthaler  ( www.msigi.net )
#   June 16, 2005
################################################################################
use strict;
use Carp;
use IO::Socket;
################################################################################
# CONFIGURATION SECTION

my $config_server = "lab.sr.msigi.net";
my $config_port = 850;
my $config_address = 7;

# END CONFIGURATION SECTION
################################################################################

# Class variables
my $object_count = 0;   # number of instances in existance


################################################################################
return 1;   # package loaded successfully
################################################################################

##doc ---------------------------------------------------------------------- 
##doc General Information
##doc   Functions return 1 of successful and undef on error
##doc   When an error occurs, it sets an error flag and error string. If the
##doc   error flag is set, all subsequent calls will return an error and will
##doc   not execute.  This makes it possible to chain together a whole bunch
##doc   of commands in sequence, without bothering to check for errors. At
##doc   critical points, check_error() should be called to see whether all
##doc   operations so far were successful.
##doc 

################################################################################
# PUBLIC METHODS

################################################################################
##doc ---------------------------------------------------------------------- 
##doc new()
##doc Object creation
##doc Syntax:     my $g = MGPIB->new( server => 'hostname',
##doc                                 port => #,
##doc                                 address => # );
##doc 
sub new() {
  my $class = shift;
  my %params = @_;
  my $self = { };

  # Configure server hostname
  if(defined $params{'server'}) {
    $self->{config_server} = $params{'server'};
  } else {
    $self->{config_server} = $config_server;
  }
  # Configure server port
  if(defined $params{'port'}) {
    $self->{config_port} = $params{'port'};
  } else {
    $self->{config_port} = $config_port;
  }
  # Configure GPIB address
  if(defined $params{'address'}) {
    $self->{config_address} = $params{'address'};
  } else {
    $self->{config_address} = $config_address;
  }

  # Initialize some variables
  $self->{welcome} = "";
  $self->{is_connected} = 0;
  $self->{is_locked} = 0;
  $self->{has_error} = 0;
  $self->{error_number} = 0;
  $self->{error_string} = "No error";
  
  bless $self, $class;
  $self->_initialize();  # call constructor
  return $self;
} # end new()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> get_server()
##doc Return server hostname
##doc 
sub get_server {
  my $self = shift;
  return $self->{config_server};
} # end get_server()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <integer> get_port()
##doc Return server port
##doc 
sub get_port {
  my $self = shift;
  return $self->{config_port};
} # end get_port()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <integer> get_address()
##doc Return GPIB address
##doc 
sub get_address {
  my $self = shift;
  return $self->{config_address};
} # end get_address()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> get_welcome()
##doc Return welcome message given by proxy server
##doc 
sub get_welcome {
  my $self = shift;
  return $self->{welcome};
} # end get_welcome()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc set_address(#)
##doc Set GPIB address
##doc   Instrument must not be locked in order to do this
##doc 
sub set_address {
  my $self = shift;
  my $newaddr = shift;
  if ($self->{is_locked}) {
    my $oldaddr = $self->{config_address};
    $self->{has_error} = 1;
    $self->{error_number} = 60;
    $self->{error_string} = "Address change from $oldaddr to "
    . "$newaddr while instrument was locked.";
    return;  # Cannot change address while locked
  } else {
    $self->{config_address} = $newaddr;
  }
  return 1;
} # end set_address()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc connect()
##doc Connect to GPIB server
##doc 
sub connect {
  my $self = shift;

  if ($self->{has_error}) { return; }

  my $sock = IO::Socket::INET->new(PeerAddr => $self->{config_server},
                                          PeerPort => $self->{config_port},
                                          Proto => "tcp",
                                          Type => SOCK_STREAM);
  if (!defined($sock) || !($sock)) {
      $self->{has_error} = 1;
      $self->{error_number} = 61;
      $self->{error_string} = "connect()";
      return;
    }

  $self->{is_connected} = 1;      # set flag

  $self->{socket} = $sock;        # save socket for later use

  $self->{welcome} = <$sock>;     # read one line
  if (!defined($self->{welcome})) {
    $self->{has_error} = 1;
    $self->{error_number} = 63;
    $self->{error_string} = "connect() welcome";
    $self->close();
    return;
  }

  $self->{welcome} =~ s/\s*$//s;  # trim trailing newline

  return 1;

} # end connect()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc init()
##doc Initialize instrument
##doc   This will call connect() automatically if necessary
##doc 
sub init {
  my $self = shift;

  # Connect if not already connected
  if (!($self->{is_connected})) {
    # need to connect
    $self->connect();
  }

  if ($self->{has_error}) { return; }

  my $sock = $self->{socket};
  my $address = $self->{config_address};

  # Lock the instrument
  if ($self->{is_locked}) {
    # if locked, we have already init'ed and don't need to again
    return 1;
  }

  my $retval = print $sock "init $address\r\n";
  if (!defined($retval) || !($retval)) {
    $self->{has_error} = 1;
    $self->{error_number} = 62;
    $self->{error_string} = "init()";
    $self->close();
    return;
  }

  my $reply = <$sock>;
  if (!defined($reply)) {
    $self->{has_error} = 1;
    $self->{error_number} = 63;
    $self->{error_string} = "init()";
    $self->close();
    return;
  }
  $reply =~ s/\s*$//s;  # trim trailing newline

  if ($reply eq "ok") {
    # Success!
    $self->{is_locked} = 1;
    return 1;
  }

  # If we get here, something must have gone wrong
  if ($reply =~ /^error\s+\d+/) {
    # A properly formatted error occured
    $reply =~ s/^error\s+//; # remove "error " from start of string
    my $errnum = $reply;
    $errnum =~ s/\D.*//; # remove first nondigit and everything that follows
    my $errtext = $reply;
    $errtext =~ s/^\d*\s*//; # remove leading digits and whitespace
    $self->{has_error} = 1;
    $self->{error_number} = $errnum;
    $self->{error_string} = "init(): $errtext";
    return;
  }

  $self->{has_error} = 1;
  $self->{error_number} = 64;
  $self->{error_string} = "init()";
  $self->close();
  return;

} # end init()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc free()
##doc Free an instrument
##doc   Stops using an instrument but does not disconnect
##doc 
sub free {
  my $self = shift;
  if ($self->{has_error}) { return; }
  my $sock = $self->{socket};
  if ($self->{is_locked}) {
    my $retval = print $sock "free\r\n";
    if (!defined($retval) || !($retval)) {
      $self->{has_error} = 1;
      $self->{error_number} = 62;
      $self->{error_string} = "free()";
      $self->close();
      return;
    }

    my $reply = <$sock>;
    if (!defined($reply)) {
      $self->{has_error} = 1;
      $self->{error_number} = 63;
      $self->{error_string} = "free()";
      $self->close();
      return;
    }
    $reply =~ s/\s*$//s;  # trim trailing newline

    if ($reply eq "ok") {
      # Success!
      $self->{is_locked} = 0;
      return 1;
    }

    # If we get here, something must have gone wrong
    # There should never be an error on freeing an instrument, so assume the
    # worst and close the connection
    $self->{has_error} = 1;
    $self->{error_number} = 64;
    $self->{error_string} = "free()";
    $self->close();
    return;

  }

  # Not locked, so instrument is already free
  return 1;

} # end free()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc write("string")
##doc Write string to instrument
##doc 
sub write {
  my $self = shift;
  my $buf = shift;

  if (!($self->{is_locked})) {
    # Instrument not yet locked
    $self->init();
  }

  if ($self->{has_error}) { return; }
  my $sock = $self->{socket};

  # Send the string
  my $retval = print $sock "write $buf\r\n";
  if (!defined($retval) || !($retval)) {
    $self->{has_error} = 1;
    $self->{error_number} = 62;
    $self->{error_string} = "write()";
    $self->close();
    return;
  }

  my $reply = <$sock>;
  if (!defined($reply)) {
    $self->{has_error} = 1;
    $self->{error_number} = 63;
    $self->{error_string} = "write()";
    $self->close();
    return;
  }
  $reply =~ s/\s*$//s;  # trim trailing newline

  if ($reply eq "ok") {
    # Success!
    return 1;
  }

  # If we get here, something must have gone wrong
  if ($reply =~ /^error\s+\d+/) {
    # A properly formatted error occured
    $reply =~ s/^error\s+//; # remove "error " from start of string
    my $errnum = $reply;
    $errnum =~ s/\D.*//; # remove first nondigit and everything that follows
    my $errtext = $reply;
    $errtext =~ s/^\d*\s*//; # remove leading digits and whitespace
    $self->{has_error} = 1;
    $self->{error_number} = $errnum;
    $self->{error_string} = "write(): $errtext";
    return;
  }

  $self->{has_error} = 1;
  $self->{error_number} = 64;
  $self->{error_string} = "write()";
  $self->close();
  return;

} # end write()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> read()
##doc Read string from instrument
##doc 
sub read {
  my $self = shift;

  if (!($self->{is_locked})) {
    # Instrument not yet locked
    $self->init();
  }

  if ($self->{has_error}) { return; }
  my $sock = $self->{socket};

  # Send read request
  my $retval = print $sock "read\r\n";
  if (!defined($retval) || !($retval)) {
    $self->{has_error} = 1;
    $self->{error_number} = 62;
    $self->{error_string} = "read()";
    $self->close();
    return;
  }

  my $reply = <$sock>;
  if (!defined($reply)) {
    $self->{has_error} = 1;
    $self->{error_number} = 63;
    $self->{error_string} = "read()";
    $self->close();
    return;
  }
  $reply =~ s/\s*$//s;  # trim trailing newline

  if ($reply =~ /^read\s/s) {
    # Success!
    $reply =~ s/^read\s*//s;
    return $reply;
  }

  # If we get here, something must have gone wrong
  if ($reply =~ /^error\s+\d+/) {
    # A properly formatted error occured
    $reply =~ s/^error\s+//; # remove "error " from start of string
    my $errnum = $reply;
    $errnum =~ s/\D.*//; # remove first nondigit and everything that follows
    my $errtext = $reply;
    $errtext =~ s/^\d*\s*//; # remove leading digits and whitespace
    $self->{has_error} = 1;
    $self->{error_number} = $errnum;
    $self->{error_string} = "read(): $errtext";
    return;
  }

  $self->{has_error} = 1;
  $self->{error_number} = 64;
  $self->{error_string} = "read()";
  $self->close();
  return;

} # end read()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> query("string")
##doc Query instrument
##doc 
sub query {
  my $self = shift;
  my $buf = shift;

  if (!($self->{is_locked})) {
    # No instrument is locked yet
    $self->init();
  }

  if ($self->{has_error}) { return; }
  my $sock = $self->{socket};

  # Send the string
  my $retval = print $sock "query $buf\r\n";
  if (!defined($retval) || !($retval)) {
    $self->{has_error} = 1;
    $self->{error_number} = 62;
    $self->{error_string} = "query()";
    $self->close();
    return;
  }

  my $reply = <$sock>;
  if (!defined($reply)) {
    $self->{has_error} = 1;
    $self->{error_number} = 63;
    $self->{error_string} = "query()";
    $self->close();
    return;
  }
  $reply =~ s/\s*$//s;  # trim trailing newline

  if ($reply =~ /^read\s/s) {
    # Success!
    $reply =~ s/^read\s*//s;
    return $reply;
  }

  # If we get here, something must have gone wrong
  if ($reply =~ /^error\s+\d+/) {
    # A properly formatted error occured
    $reply =~ s/^error\s+//; # remove "error " from start of string
    my $errnum = $reply;
    $errnum =~ s/\D.*//; # remove first nondigit and everything that follows
    my $errtext = $reply;
    $errtext =~ s/^\d*\s*//; # remove leading digits and whitespace
    $self->{has_error} = 1;
    $self->{error_number} = $errnum;
    $self->{error_string} = "query(): $errtext";
    return;
  }

  $self->{has_error} = 1;
  $self->{error_number} = 64;
  $self->{error_string} = "query()";
  $self->close();
  return;

} # end query()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc close()
##doc Close connection
##doc   Unlocks instrument and closes the connection
##doc 
sub close {
  my $self = shift;
  my $sock = $self->{socket};
  if ($self->{is_connected}) {
    print $sock "close\r\n"; # if this fails we don't care
    $self->{is_connected} = 0;
    $self->{is_locked} = 0;
    close($sock);
  }
  if ($self->{has_error}) { return; }
  return 1;
} # end close()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc check_error()
##doc Checks error
##doc   Returns 1 if there has been an error, 0 otherwise
##doc 
sub check_error {
  my $self = shift;
  if ($self->{has_error}) {
    return 1;  # error
  }
  return;    # no error
} # end check_error()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> get_error()
##doc Get error
##doc   Returns a detailed string describing the error
##doc 
sub get_error {
  my $self = shift;
  my $errnum = $self->{error_number};
  my $errtypestr = $self->lookup_error($self->{error_number});
  my $errlocstr = $self->{error_string};
  my $errstr = "ERROR $errnum: $errtypestr: $errlocstr";
  return $errstr;
} # end get_error()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc die_error()
##doc Die on error
##doc   Checks whether an error has occured, and dies if so
##doc 
sub die_error {
  my $self = shift;
  if ($self->check_error()) {
    my $errstr = $self->get_error();
    croak $errstr;
  }
  return 1;
} # end die_error()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc <string> lookup_error(#)
##doc Lookup error
##doc   Returns a string for a particular error number
##doc 
sub lookup_error {
  my $self = shift;
  my $errnum = shift;
  if ($errnum==60) {
    return "Paramter updated failed.";
  } elsif ($errnum==61) {
    return "Cannot open connection";
  } elsif ($errnum==62) {
    return "Cannot write to socket";
  } elsif ($errnum==63) {
    return "Cannot read from socket";
  } elsif ($errnum==64) {
    return "Protocol violation";
  } elsif ($errnum==31) {
    return "Server said bad command";
  } elsif ($errnum==32) {
    return "GPIB communications error";
  } elsif ($errnum==33) {
    return "Fatal error";
  } elsif ($errnum==34) {
    return "Resource unavailable";
  } elsif ($errnum==35) {
    return "Server has internal error";
  } else {
    return "";
  }
} # end lookup_error()
################################################################################

################################################################################
##doc ---------------------------------------------------------------------- 
##doc clear_error()
##doc Clear error
##doc   Resets the error flag and error string
##doc 
sub clear_error {
  my $self = shift;
  $self->{has_error} = 0;
  $self->{error_number} = 0;
  $self->{error_string} = "No error";
  return 1;
} # end clear_error()
################################################################################

################################################################################

# END PUBLIC METHODS
################################################################################
# PRIVATE METHODS
# The following methods should not be called from outside the package


################################################################################
# Object constructor
sub _initialize {
  my $self = shift;
  if(!$object_count) {
    # this is the first instance
  }
  $object_count++;
}
################################################################################


################################################################################
# Object destructor
sub DESTROY {
  my $self = shift;
  $self->close();
  $object_count--;
  if(!$object_count) {
    # this is the last instance
  }
} # end DESTROY()
################################################################################