1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--           G N A T . S E R I A L _ C O M M U N I C A T I O N S            --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--                    Copyright (C) 2007-2015, AdaCore                      --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This is the GNU/Linux implementation of this package
33
34with Ada.Streams;                use Ada.Streams;
35with Ada;                        use Ada;
36with Ada.Unchecked_Deallocation;
37
38with System;               use System;
39with System.Communication; use System.Communication;
40with System.CRTL;          use System.CRTL;
41with System.OS_Constants;
42
43with GNAT.OS_Lib; use GNAT.OS_Lib;
44
45package body GNAT.Serial_Communications is
46
47   package OSC renames System.OS_Constants;
48
49   use type Interfaces.C.unsigned;
50
51   type Port_Data is new int;
52
53   subtype unsigned is Interfaces.C.unsigned;
54   subtype char is Interfaces.C.char;
55   subtype unsigned_char is Interfaces.C.unsigned_char;
56
57   function fcntl (fd : int; cmd : int; value : int) return int;
58   pragma Import (C, fcntl, "fcntl");
59
60   C_Data_Rate : constant array (Data_Rate) of unsigned :=
61                   (B75     => OSC.B75,
62                    B110    => OSC.B110,
63                    B150    => OSC.B150,
64                    B300    => OSC.B300,
65                    B600    => OSC.B600,
66                    B1200   => OSC.B1200,
67                    B2400   => OSC.B2400,
68                    B4800   => OSC.B4800,
69                    B9600   => OSC.B9600,
70                    B19200  => OSC.B19200,
71                    B38400  => OSC.B38400,
72                    B57600  => OSC.B57600,
73                    B115200 => OSC.B115200);
74
75   C_Bits      : constant array (Data_Bits) of unsigned :=
76                   (CS7 => OSC.CS7, CS8 => OSC.CS8);
77
78   C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
79                   (One => 0, Two => OSC.CSTOPB);
80
81   C_Parity    : constant array (Parity_Check) of unsigned :=
82                   (None => 0,
83                    Odd  => OSC.PARENB or OSC.PARODD,
84                    Even => OSC.PARENB);
85
86   procedure Raise_Error (Message : String; Error : Integer := Errno);
87   pragma No_Return (Raise_Error);
88
89   ----------
90   -- Name --
91   ----------
92
93   function Name (Number : Positive) return Port_Name is
94      N     : constant Natural := Number - 1;
95      N_Img : constant String  := Natural'Image (N);
96   begin
97      return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last));
98   end Name;
99
100   ----------
101   -- Open --
102   ----------
103
104   procedure Open
105     (Port : out Serial_Port;
106      Name : Port_Name)
107   is
108      use OSC;
109
110      C_Name : constant String := String (Name) & ASCII.NUL;
111      Res    : int;
112
113   begin
114      if Port.H = null then
115         Port.H := new Port_Data;
116      end if;
117
118      Port.H.all := Port_Data (open
119         (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY)));
120
121      if Port.H.all = -1 then
122         Raise_Error ("open: open failed");
123      end if;
124
125      --  By default we are in blocking mode
126
127      Res := fcntl (int (Port.H.all), F_SETFL, 0);
128
129      if Res = -1 then
130         Raise_Error ("open: fcntl failed");
131      end if;
132   end Open;
133
134   -----------------
135   -- Raise_Error --
136   -----------------
137
138   procedure Raise_Error (Message : String; Error : Integer := Errno) is
139   begin
140      raise Serial_Error with Message
141        & (if Error /= 0
142           then " (" & Errno_Message (Err => Error) & ')'
143           else "");
144   end Raise_Error;
145
146   ----------
147   -- Read --
148   ----------
149
150   overriding procedure Read
151     (Port   : in out Serial_Port;
152      Buffer : out Stream_Element_Array;
153      Last   : out Stream_Element_Offset)
154   is
155      Len : constant size_t := Buffer'Length;
156      Res : ssize_t;
157
158   begin
159      if Port.H = null then
160         Raise_Error ("read: port not opened", 0);
161      end if;
162
163      Res := read (Integer (Port.H.all), Buffer'Address, Len);
164
165      if Res = -1 then
166         Raise_Error ("read failed");
167      end if;
168
169      Last := Last_Index (Buffer'First, size_t (Res));
170   end Read;
171
172   ---------
173   -- Set --
174   ---------
175
176   procedure Set
177     (Port      : Serial_Port;
178      Rate      : Data_Rate        := B9600;
179      Bits      : Data_Bits        := CS8;
180      Stop_Bits : Stop_Bits_Number := One;
181      Parity    : Parity_Check     := None;
182      Block     : Boolean          := True;
183      Local     : Boolean          := True;
184      Flow      : Flow_Control     := None;
185      Timeout   : Duration         := 10.0)
186   is
187      use OSC;
188
189      type termios is record
190         c_iflag  : unsigned;
191         c_oflag  : unsigned;
192         c_cflag  : unsigned;
193         c_lflag  : unsigned;
194         c_line   : unsigned_char;
195         c_cc     : Interfaces.C.char_array (0 .. 31);
196         c_ispeed : unsigned;
197         c_ospeed : unsigned;
198      end record;
199      pragma Convention (C, termios);
200
201      function tcgetattr (fd : int; termios_p : Address) return int;
202      pragma Import (C, tcgetattr, "tcgetattr");
203
204      function tcsetattr
205        (fd : int; action : int; termios_p : Address) return int;
206      pragma Import (C, tcsetattr, "tcsetattr");
207
208      function tcflush (fd : int; queue_selector : int) return int;
209      pragma Import (C, tcflush, "tcflush");
210
211      Current : termios;
212
213      Res : int;
214      pragma Warnings (Off, Res);
215      --  Warnings off, since we don't always test the result
216
217   begin
218      if Port.H = null then
219         Raise_Error ("set: port not opened", 0);
220      end if;
221
222      --  Get current port settings
223
224      Res := tcgetattr (int (Port.H.all), Current'Address);
225
226      --  Change settings now
227
228      Current.c_cflag := C_Data_Rate (Rate)
229                           or C_Bits (Bits)
230                           or C_Stop_Bits (Stop_Bits)
231                           or C_Parity (Parity)
232                           or CREAD;
233      Current.c_iflag := 0;
234      Current.c_lflag := 0;
235      Current.c_oflag := 0;
236
237      if Local then
238         Current.c_cflag := Current.c_cflag or CLOCAL;
239      end if;
240
241      case Flow is
242         when None     =>
243            null;
244         when RTS_CTS  =>
245            Current.c_cflag := Current.c_cflag or CRTSCTS;
246         when Xon_Xoff =>
247            Current.c_iflag := Current.c_iflag or IXON;
248      end case;
249
250      Current.c_ispeed     := Data_Rate_Value (Rate);
251      Current.c_ospeed     := Data_Rate_Value (Rate);
252      Current.c_cc (VMIN)  := char'Val (0);
253      Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
254
255      --  Set port settings
256
257      Res := tcflush (int (Port.H.all), TCIFLUSH);
258      Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
259
260      --  Block
261
262      Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
263
264      if Res = -1 then
265         Raise_Error ("set: fcntl failed");
266      end if;
267   end Set;
268
269   -----------
270   -- Write --
271   -----------
272
273   overriding procedure Write
274     (Port   : in out Serial_Port;
275      Buffer : Stream_Element_Array)
276   is
277      Len : constant size_t := Buffer'Length;
278      Res : ssize_t;
279
280   begin
281      if Port.H = null then
282         Raise_Error ("write: port not opened", 0);
283      end if;
284
285      Res := write (int (Port.H.all), Buffer'Address, Len);
286
287      if Res = -1 then
288         Raise_Error ("write failed");
289      end if;
290
291      pragma Assert (size_t (Res) = Len);
292   end Write;
293
294   -----------
295   -- Close --
296   -----------
297
298   procedure Close (Port : in out Serial_Port) is
299      procedure Unchecked_Free is
300        new Unchecked_Deallocation (Port_Data, Port_Data_Access);
301
302      Res : int;
303      pragma Unreferenced (Res);
304
305   begin
306      if Port.H /= null then
307         Res := close (int (Port.H.all));
308         Unchecked_Free (Port.H);
309      end if;
310   end Close;
311
312end GNAT.Serial_Communications;
313