[size=10pt][font=courier]program lserver;
{$mode objfpc}{$H+}
uses
rpi_hal,pfio,
Classes, Crt, SysUtils, lNet, Process, fptimer;
type
{ TLTCPTest }
TLTCPTest = class
private
Timer1: TFPTimer;
FCon: TLTCP; // THE server connection
{ these are all events which happen on our server connection. They are called inside CallAction
OnEr gets fired when a network error occurs.
OnAc gets fired when a new connection is accepted on the server socket.
OnRe gets fired when any of the server sockets receives new data.
OnDs gets fired when any of the server sockets disconnects gracefully.
}
procedure OnEr(const msg: string; aSocket: TLSocket);
procedure OnAc(aSocket: TLSocket);
procedure OnRe(aSocket: TLSocket);
procedure OnDs(aSocket: TLSocket);
procedure TimerExec(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
procedure Run; // main loop with CallAction
function getRelay(lednr:byte):boolean;
procedure setRelay(lednr:byte;Enabled:Boolean);
procedure playsound ;
end;
procedure TLTCPTest.OnEr(const msg: string; aSocket: TLSocket);
begin
// Writeln(msg); // if error occured, write it explicitly
end;
procedure TLTCPTest.OnAc(aSocket: TLSocket);
begin
//Writeln('Connection accepted from ', aSocket.PeerAddress); // on accept, write whom we accepted
end;
procedure TLTCPTest.playsound ;
var
AProcess : TProcess;
begin
AProcess := TProcess.Create(nil);
AProcess.FreeOnRelease;
AProcess.Executable := '/usr/bin/aplay';
AProcess.Parameters.Add(' /home/pi/WVW_TTS_FILES/relay1on.wav');
AProcess.Execute;
end;
function TLTCPTest.getRelay(lednr:byte):boolean;
var b:Boolean; GPIOnr:Byte;
begin
if lednr = 1 then GPIOnr := 27;
if lednr = 2 then GPIOnr := 23;
if lednr = 3 then GPIOnr := 15;
if lednr = 4 then GPIOnr := 14;
if lednr = 5 then GPIOnr := 7;
gpio_set_output(GPIOnr);
b:=GPIO_get_PIN(gpionr);
result := b;
end;
procedure TLTCPTest.setRelay(lednr:byte;Enabled:Boolean);
var GPIOnr:Byte;
begin
if lednr = 1 then GPIOnr := 27;
if lednr = 2 then GPIOnr := 23;
if lednr = 3 then GPIOnr := 15;
if lednr = 4 then GPIOnr := 14;
if lednr = 5 then GPIOnr := 7;
playsound;
gpio_set_output(GPIOnr);
gpio_set_pin (GPIOnr,Enabled);
end;
procedure TLTCPTest.TimerExec(Sender: TObject);
begin
FCon.SendMessage('TIMER! EVENT WVW');
Writeln('TIMER! EVENT WVW');
end;
procedure TLTCPTest.OnRe(aSocket: TLSocket);
var
GS,t,s: string;
n: Integer;
begin
T:=TimeToStr(Time);
if aSocket.GetMessage(s) > 0 then
begin // if we received anything (result is in s)
if (S='[SET11]') then begin Writeln('WVW '+T+': Relay 1 Enabled - GPIO27'); setRelay(1,True); end;
if (S='[SET10]') then begin Writeln('WVW '+T+': Relay 1 Disabled - GPIO27'); setRelay(1,False);end;
if (S='[SET21]') then begin Writeln('WVW '+T+': Relay 2 Enabled - GPIO23'); setRelay(2,True);end;
if (S='[SET20]') then begin Writeln('WVW '+T+': Relay 2 Disabled - GPIO23'); setRelay(2,False); end;
if (S='[SET31]') then begin Writeln('WVW '+T+': Relay 3 Enabled - GPIO15'); setRelay(3,True);end;
if (S='[SET30]') then begin Writeln('WVW '+T+': Relay 3 Disabled - GPIO15'); setRelay(3,False);end;
if (S='[SET41]') then begin Writeln('WVW '+T+': Relay 4 Enabled - GPIO14'); setRelay(4,True);end;
if (S='[SET40]') then begin Writeln('WVW '+T+': Relay 4 Disabled - GPIO14'); setRelay(4,False);end;
if (S='[SET51]') then begin Writeln('WVW '+T+': Relay 5 Disabled - GPIO4'); setRelay(5,True);end;
if (S='[SET50]') then begin Writeln('WVW '+T+': Relay 5 Disabled - GPIO4'); setRelay(5,False);end;
//if (S='[R]') then
begin
GS:='';
if (getRelay(1) = True) then begin GS:=GS+' [GET11] '; end else begin GS:=GS+' [GET10] ';end;
if (getRelay(2) = True) then begin GS:=GS+' [GET21] '; end else begin GS:=GS+' [GET20] ';end;
if (getRelay(3) = True) then begin GS:=GS+' [GET31] '; end else begin GS:=GS+' [GET30] ';end;
if (getRelay(4) = True) then begin GS:=GS+' [GET41] '; end else begin GS:=GS+' [GET40] ';end;
if (getRelay(5) = True) then begin GS:=GS+' [GET51] '; end else begin GS:=GS+' [GET50] ';end;
Writeln('GS:'+GS);
FCon.SendMessage(GS, FCon.Iterator);
end;
FCon.IterReset; // now it points to server socket
while FCon.IterNext do begin // while we have clients to echo to
n := FCon.SendMessage(s, FCon.Iterator);
if n < Length(s) then // try to send to each of them
Writeln('WVW ERROR: Unsuccessful send, wanted: ', Length(s), ' got: ', n); // if send fails write error
end;
end;
end;
procedure TLTCPTest.OnDs(aSocket: TLSocket);
begin
// Writeln('Lost connection'); // write info if connection was lost
end;
constructor TLTCPTest.Create;
begin
FCon := TLTCP.Create(nil); // create new TCP connection
FCon.OnError := @OnEr; // assign all callbacks
FCon.OnReceive := @OnRe;
FCon.OnDisconnect := @OnDs;
FCon.OnAccept := @OnAc;
FCon.Timeout := 100; // responsive enough, but won't hog cpu
FCon.ReuseAddress := True;
end;
destructor TLTCPTest.Destroy;
begin
FCon.Free; // free the TCP connection
inherited Destroy;
end;
procedure TLTCPTest.Run;
var
Quit: Boolean; // main loop control
Port: Word; // the port to connect to
begin
Timer1 := TFPTimer.Create(nil);
Timer1.onTimer := @TimerExec;
Timer1.interval := 300;
Timer1.Enabled := True;
if ParamCount > 0 then begin // we need one argument
try
Port := Word(StrToInt(ParamStr(1))); // try to parse port from argument
except
on e: Exception do begin
Writeln(e.message);
Halt;
end;
end;
Quit := false;
if FCon.Listen(Port) then begin // if listen went ok
Writeln('Server running!');
Writeln('Press ''escape'' to quit, ''r'' to restart');
repeat
FCon.Callaction; // eventize the lNet
if Keypressed then // if user provided input
case readkey of
#27: quit := true; // if he pressed "escape" then quit
'r': begin // if he pressed 'r' then restart the server
Writeln('Restarting...');
FCon.Disconnect;
FCon.Listen(Port);
Quit := false;
end;
end;
until Quit; // until user quit
end; // listen
end else Writeln('Usage: ', ParamStr(0), ' <port>');
end;
var
TCP: TLTCPTest;
begin
TCP := TLTCPTest.Create;
TCP.Run;
TCP.Free;
end.
[/font][/size]
Recent
