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