#!/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);
 }
}