GitLab Commit is coming up on August 3-4. Learn how to innovate together using GitLab, the DevOps platform. Register for free: gitlabcommitvirtual2021.com

Commit 4ae95a87 authored by Stéphane LOS's avatar Stéphane LOS
Browse files

Added libsnap7 binding and tests

parent 30a6fc0f
Pipeline #313216179 passed with stages
in 3 minutes and 31 seconds
project Libsnap7 is
for Languages use ("C");
for Library_Name use "snap7";
for Library_Kind use "dynamic";
for Externally_Built use "True";
-- for Library_Dir use "..\..\SNAP7\snap7-full-1.4.2\release\Windows\Win64";
-- for Library_Dir use "..\..\SNAP7\snap7-full-1.4.2\build\bin\Legacy\win64";
for Library_Dir use "..\..\SNAP7\snap7-full-1.4.2\build\windows\GNAT\libs\x86_64";
for Source_Dirs use ("..\..\SNAP7\snap7-full-1.4.2\release\Wrappers\c-cpp");
end Libsnap7;
------------------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2021, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings;
package body A4A.Protocols.LibSnap7 is
function Cli_ConnectTo (Client : S7Object;
IP_Address : in String;
Rack : in Natural;
Slot : in Natural) return C.int is
function Snap7_Cli_ConnectTo
(Client : in S7Object;
IP_Address : in C.Strings.chars_ptr;
Rack : in C.int;
Slot : in C.int)
return C.int;
-- int S7API Cli_ConnectTo(S7Object Client, const char *Address,
-- int Rack, int Slot);
pragma Import (C, Snap7_Cli_ConnectTo, "Cli_ConnectTo");
IP_Address_ptr : C.Strings.chars_ptr;
Result : C.int;
begin
IP_Address_ptr := C.Strings.New_String (IP_Address);
Result := Snap7_Cli_ConnectTo (Client => Client,
IP_Address => IP_Address_ptr,
Rack => C.int (Rack),
Slot => C.int (Slot));
C.Strings.Free (IP_Address_ptr);
return Result;
end Cli_ConnectTo;
end A4A.Protocols.LibSnap7;
------------------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2021, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
-- <summary>
-- This package provides the binding to libsnap7, a library implementing
-- the Siemens S7 communication protocol.
-- </summary>
-- <description>
-- It provides :
-- - libsnap7 data types,
-- - libsnap7 C functions binding.
-- </description>
-- <group>Protocols</group>
-- <c_version>1.4.2</c_version>
-- with System; use System;
with Interfaces.C;
package A4A.Protocols.LibSnap7 is
package C renames Interfaces.C;
type S7Object is private;
-- typedef uintptr_t S7Object;
-- // multi platform/processor object reference
-- // DON'T CONFUSE IT WITH AN OLE OBJECT, IT'S SIMPLY
-- // AN INTEGER VALUE (32 OR 64 BIT) USED AS HANDLE.
function Cli_Create return S7Object;
-- S7Object S7API Cli_Create();
procedure Cli_Destroy (Client : access S7Object);
-- void S7API Cli_Destroy(S7Object *Client);
function Cli_ConnectTo (Client : in S7Object;
IP_Address : in String;
Rack : in Natural;
Slot : in Natural) return C.int;
-- int S7API Cli_ConnectTo(S7Object Client, const char *Address, int Rack,
-- int Slot);
function Cli_Disconnect (Client : in S7Object) return C.int;
-- int S7API Cli_Disconnect(S7Object Client);
------------------------------------------------------------------------------
-- Data I/O Lean functions
------------------------------------------------------------------------------
function Cli_DBRead (Client : in S7Object;
DBNumber : in Natural;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_DBRead(S7Object Client, int DBNumber, int Start, int Size,
-- void *pUsrData);
function Cli_DBWrite (Client : in S7Object;
DBNumber : in Natural;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_DBWrite(S7Object Client, int DBNumber, int Start,
-- int Size, void *pUsrData);
function Cli_MBRead (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_MBRead(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_MBWrite (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_MBWrite(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_EBRead (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_EBRead(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_EBWrite (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_EBWrite(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_ABRead (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_ABRead(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_ABWrite (Client : in S7Object;
Start : in Natural;
Size : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_ABWrite(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_TMRead (Client : in S7Object;
Start : in Natural;
Amount : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_TMRead(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_TMWrite (Client : in S7Object;
Start : in Natural;
Amount : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_TMWrite(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_CTRead (Client : in S7Object;
Start : in Natural;
Amount : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_CTRead(S7Object Client, int Start, int Size,
-- void *pUsrData);
function Cli_CTWrite (Client : in S7Object;
Start : in Natural;
Amount : in Natural;
UsrData : Byte_Array) return C.int;
-- int S7API Cli_CTWrite(S7Object Client, int Start, int Size,
-- void *pUsrData);
private
type S7Object is new C.unsigned_long_long;
-- typedef uintptr_t S7Object;
-- // multi platform/processor object reference
-- // DON'T CONFUSE IT WITH AN OLE OBJECT, IT'S SIMPLY
-- // AN INTEGER VALUE (32 OR 64 BIT) USED AS HANDLE.
pragma Import (C, Cli_Create, "Cli_Create");
pragma Import (C, Cli_Destroy, "Cli_Destroy");
pragma Import (C, Cli_Disconnect, "Cli_Disconnect");
pragma Import (C, Cli_DBRead, "Cli_DBRead");
pragma Import (C, Cli_DBWrite, "Cli_DBWrite");
pragma Import (C, Cli_MBRead, "Cli_MBRead");
pragma Import (C, Cli_MBWrite, "Cli_MBWrite");
pragma Import (C, Cli_EBRead, "Cli_EBRead");
pragma Import (C, Cli_EBWrite, "Cli_EBWrite");
pragma Import (C, Cli_ABRead, "Cli_ABRead");
pragma Import (C, Cli_ABWrite, "Cli_ABWrite");
pragma Import (C, Cli_TMRead, "Cli_TMRead");
pragma Import (C, Cli_TMWrite, "Cli_TMWrite");
pragma Import (C, Cli_CTRead, "Cli_CTRead");
pragma Import (C, Cli_CTWrite, "Cli_CTWrite");
end A4A.Protocols.LibSnap7;
with "../gpr/libsnap7.gpr";
project A4A_Test_S7 extends "../gpr/a4a.gpr" is
for Languages use ("Ada");
for Object_Dir use "./obj";
for Exec_Dir use "./bin";
for Source_Dirs use ("./src");
for Main use ("test_libsnap7_client");
package Documentation is
for Documentation_Dir use "./doc";
end Documentation;
end A4A_Test_S7;
------------------------------------------------------------------------------
-- Ada for Automation --
-- --
-- Copyright (C) 2012-2021, Stephane LOS --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Interfaces.C; use Interfaces.C;
with A4A; use A4A;
with A4A.Protocols.LibSnap7; use A4A.Protocols.LibSnap7;
with A4A.Library.Conversion; use A4A.Library.Conversion;
procedure Test_libsnap7_client is
-- Should work on Linux
-- GREEN_STRING_START : constant String := "\033[42m";
-- GREEN_STRING_STOP : constant String := "\033[m";
-- On Windows, not supported until W10...
GREEN_STRING_START : constant String := "";
GREEN_STRING_STOP : constant String := "";
Client : aliased S7Object;
Result : C.int;
Connected : Boolean := False;
MyUsrDataIn : aliased Byte_Array (0 .. 19) := (others => 0);
MyUsrDataOut : Byte_Array (0 .. 19) := (others => 0);
MW0 : Word := 0;
MW2 : Word := 0;
MW4 : Word := 0;
MD8 : DWord := 0;
MD8F : Float := 0.0;
EW0 : Word := 0;
AW0 : Word := 0;
DB1_W0 : Word := 0;
T1 : Word := 0;
C1 : Word := 0;
procedure Byte_String
(Item : Byte; Buffer : in out String; Pos : in out Integer);
procedure Byte_String
(Item : Byte; Buffer : in out String; Pos : in out Integer) is
Hex : constant array
(Byte range 0 .. 15) of Character := "0123456789ABCDEF";
begin
Buffer (Pos) := Hex (Item / 16);
Buffer (Pos + 1) := Hex (Item mod 16);
Pos := Pos + 2;
end Byte_String;
function Data_String (DataIn : Byte_Array) return String;
function Data_String (DataIn : Byte_Array) return String is
Data_Count : constant Natural := DataIn'Length;
-- We want to display the data bytes in hex
-- 00, ff, ...
-- 00 is 2
-- 00, ff is 6
-- 00, aa, ff is 10
Result : String (1 .. (Data_Count * 4) - 2) := (others => ' ');
Pos : Integer := Result'First;
Index : Integer := DataIn'First;
begin
Byte_String
(Item => DataIn (Index),
Buffer => Result,
Pos => Pos);
loop
Index := Index + 1;
exit when Index > DataIn'First + Data_Count - 1;
if (Index - 1) mod 10 = 9 then
Result (Pos .. Pos + 1) := CRLF;
else
Result (Pos .. Pos + 1) := ", ";
end if;
Pos := Pos + 2;
Byte_String
(Item => DataIn (Index),
Buffer => Result,
Pos => Pos);
end loop;
return Result;
end Data_String;
------------------------------------------------------------------------------
-- Show_Data --
------------------------------------------------------------------------------
procedure Show_Data (DataIn : Byte_Array);
procedure Show_Data (DataIn : Byte_Array) is
What : constant String := CRLF & GREEN_STRING_START
& "***********************************************" & CRLF
& " MyUsrData in Hex" & CRLF & CRLF
& Data_String (DataIn => DataIn) & CRLF
& "***********************************************"
& GREEN_STRING_STOP & CRLF;
begin
Put (What);
end Show_Data;
------------------------------------------------------------------------------
-- Mementos Read / Write tests --
------------------------------------------------------------------------------
procedure Test_Mementos;
procedure Test_Mementos is
begin
MyUsrDataIn := (others => 0);
Result := Cli_MBRead (Client => Client,
Start => 0,
Size => MyUsrDataIn'Length,
UsrData => MyUsrDataIn);
if Result = 0 then
Show_Data (DataIn => MyUsrDataIn);
Bytes_To_Word (LSB_Byte => MyUsrDataIn (1),
MSB_Byte => MyUsrDataIn (0),
Word_out => MW0);
Put_Line ("Read MW0 : " & MW0'Img & " ! :-)");
Bytes_To_Word (LSB_Byte => MyUsrDataIn (3),
MSB_Byte => MyUsrDataIn (2),
Word_out => MW2);
Put_Line ("Read MW2 : " & MW2'Img & " ! :-)");
Bytes_To_Word (LSB_Byte => MyUsrDataIn (5),
MSB_Byte => MyUsrDataIn (4),
Word_out => MW4);
Put_Line ("Read MW4 : " & MW4'Img & " ! :-)");
Bytes_To_DWord (Byte0 => MyUsrDataIn (11),
Byte1 => MyUsrDataIn (10),
Byte2 => MyUsrDataIn (9),
Byte3 => MyUsrDataIn (8),
DWord_out => MD8);
Put_Line ("Read MD8 : " & MD8'Img & " ! :-)");
MD8F := DWord_To_Float (MD8);
Put_Line ("Read MD8F : " & MD8F'Img & " ! :-)");
else
Put_Line ("Read Mementos failed ! :-(");
end if;
MyUsrDataOut (0 .. 3) := MyUsrDataIn (8 .. 11);
Result := Cli_MBWrite (Client => Client,
Start => MyUsrDataIn'Length,
Size => MyUsrDataOut'Length,
UsrData => MyUsrDataOut);
if Result = 0 then
Put_Line ("Write MB succeeded! :-)");
else
Put_Line ("Write MB failed ! :-(");
end if;
end Test_Mementos;
------------------------------------------------------------------------------
-- Inputs Read / Write tests --
------------------------------------------------------------------------------
procedure Test_Inputs;
procedure Test_Inputs is
begin
MyUsrDataIn := (others => 0);
Result := Cli_EBRead (Client => Client,
Start => 0,
Size => MyUsrDataIn'Length,
UsrData => MyUsrDataIn);
if Result = 0 then
Bytes_To_Word (LSB_Byte => MyUsrDataIn (1),
MSB_Byte => MyUsrDataIn (0),
Word_out => EW0);
Put_Line ("Read EW0 : " & EW0'Img & " ! :-)");
MyUsrDataOut (0 .. 3) := MyUsrDataIn (0 .. 3);
else
Put_Line ("Read Inputs failed ! :-(");
end if;
Result := Cli_EBWrite (Client => Client,
Start => 10,
Size => MyUsrDataOut'Length,
UsrData => MyUsrDataOut);
if Result = 0 then
Put_Line ("Write EB succeeded! :-)");
else
Put_Line ("Write EB failed ! :-(");
end if;
end Test_Inputs;
------------------------------------------------------------------------------
-- Outputs Read / Write tests --
------------------------------------------------------------------------------
procedure Test_Outputs;
procedure Test_Outputs is
begin
MyUsrDataIn := (others => 0);
Result := Cli_ABRead (Client => Client,
Start => 0,
Size => MyUsrDataIn'Length,
UsrData => MyUsrDataIn);
if Result = 0 then
Bytes_To_Word (LSB_Byte => MyUsrDataIn (1),
MSB_Byte => MyUsrDataIn (0),
Word_out => AW0);
Put_Line ("Read AW0 : " & AW0'Img & " ! :-)");
MyUsrDataOut (0 .. 3) := MyUsrDataIn (0 .. 3);
else
Put_Line ("Read Outputs failed ! :-(");
end if;
Result := Cli_ABWrite (Client => Client,
Start => 10,
Size => MyUsrDataOut'Length,
UsrData => MyUsrDataOut);
if Result = 0 then
Put_Line ("Write AB succeeded! :-)");
else
Put_Line ("Write AB failed ! :-(");
end if;
end Test_Outputs;
------------------------------------------------------------------------------
-- Data Blocks Read / Write tests --
------------------------------------------------------------------------------
procedure Test_DBs;
procedure Test_DBs is
begin
MyUsrDataIn := (others => 0);
Result := Cli_DBRead (Client => Client,
DBNumber => 1,
Start => 0,
Size => MyUsrDataIn'Length,
UsrData => MyUsrDataIn);
if Result = 0 then
Bytes_To_Word (LSB_Byte => MyUsrDataIn (1),
MSB_Byte => MyUsrDataIn (0),
Word_out => DB1_W0);
Put_Line ("Read DB1.DBW0 : " & DB1_W0'Img & " ! :-)");
MyUsrDataOut (0 .. 3) := MyUsrDataIn (0 .. 3);
else
Put_Line ("Read Data Block failed ! :-(");
end if;
Result := Cli_DBWrite (Client => Client,
DBNumber => 1,
Start => 10,
Size => MyUsrDataOut'Length,
UsrData => MyUsrDataOut);
if Result = 0 then
Put_Line ("Write Data Block succeeded! :-)");
else
Put_Line ("Write Data Block failed ! :-(");