#!/usr/bin/perl -w
# Perl Modbus Server
# Statements zur Fehlerbehandlung sind weitgehend entfernt. 
  
# Singlethreaded Server 
# In Kombination mit SysV-IPC (ShMem)
  
use Socket;
use IPC::SysV qw(IPC_RMID IPC_PRIVATE);         

# Process Id und Shared-Memory Id in Dateien
# ablegen, die den Servernamen tragen
$myself ( $0 =~ s/\.pl$// );
$pidfile = "$myself.pid";
$sidfile = "$myself.sid";

$shm_flags = 0666;  # Zugriffsrechte: rw-rw-rw-
$tcpmodbus = 502;   # Modbus well known port (privilegiert!)

$max_unit = 28;     # Anzahl der Steuerungsstationen (SPS)
$max_ref = 1024;    # letztes Register der SPS
$unit_size = 1024;  # Registeranzahl
$word_size = 2;     # Bytes pro Wort

# Platz fuer Shared Memory
$shm_size = 2 * $max_unit * $unit_size * $word_size; # array twice!

$MODBUS_READ  = 3;    # Modbus Funktion: Lesen
$MODBUS_WRITE = 0x10; # Modbus Funktion: Schreiben

# Unterprogramm zum Programmende (ausgeloest durch kill -TERM)
sub getout {
  shmctl ($sid, IPC_RMID, 0);     # Shared Memory freigeben
  unlink $pidfile, $sidfile;
  exit 0;
}

# Forken und im Hintergrund weiterarbeiten. 
if ($pid = fork) {
  exit 0;
}

# Signalhandler fuer kill -TERM bereitstellen und 
# an alle Kindprozesse vererben.
$SIG{TERM} = \&getout;

# Process Id vermerken.
open (PID, ">$pidfile");
print PID "$$\n";
close PID;

# Shared Memory anlegen
$sid = shmget(IPC_PRIVATE, $shm_size, $shm_flags);

# Shared Memory Id vermerken
open (SID, ">$sidfile");
print SID "$sid\n"; 
close SID; 

# Server Port und Protokoll 
my $port = $tcpmodbus; 
my $proto = getprotobyname('tcp');

# Server socket erstellen, 
# Hostadresse binden und 
# auf Requests warten
socket(Server, PF_INET, SOCK_STREAM, $proto);
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)); 
bind (Server, sockaddr_in($port, INADDR_ANY));
listen (Server, SOMAXCONN);

my $paddr;
# Endlos Verbindungen akzeptieren, bearbeiten und 
# wieder schließen. 
for ( ; $paddr = accept(Client, Server); close Client ) {
  my ($port, $iaddr) = sockaddr_in($paddr);    
  my ($ta_id, $prot_id, $ta_len, $unit_id, $mb_fc, $bc, 
      $ref, $count, $data, @data, $got, $line, $header, 
      $req, $sent, $string);
  
  $req = 12; # Die ersten 12 bytes lesen
  recv Client, $line, $req, 0;
  # und in ihre Bestandteile zerlegen
  ($ta_id, $prot_id, $ta_len, $unit_id, $mb_fc, $ref, $count) = 
    unpack "nnnCCnn", $line; 
  if ( $mb_fc == $MODBUS_READ ) {
    # mehr lesen
    shmread $sid, $line, 2*$ref, 2*$count;
    $line = pack('n*', unpack 'S*', $line);
    $header = pack 'nnnCCC',
    $ta_id, $prot_id, 2*$count+3, $unit_id, $mb_fc, 0xff; 
    $string = $header . $line; 
    # und antworten
    send(Client, $string, 0); 
  } elsif ( $mb_fc == $MODBUS_WRITE ) {
    # oder schreiben
    $req = 2*$count+1; 
    recv Client, $line, $req, 0;
    ($bc, @data) = unpack 'Cn*', $line;
    shmwrite ($sid, pack ('S*', @data), 
	      2*(($unit_id-1)*$unit_size+$ref), 2*$count);
    $header = pack 'nnnCCCnn',
    $ta_id, $prot_id, 5, $unit_id, $mb_fc, $ref, $count; 
    send (Client, $header, 0);
  }
}