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-2018, 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 Windows implementation of this package
33
34with Ada.Streams;                use Ada.Streams;
35with Ada.Unchecked_Deallocation; use Ada;
36
37with System;               use System;
38with System.Communication; use System.Communication;
39with System.CRTL;          use System.CRTL;
40with System.OS_Constants;
41with System.Win32;         use System.Win32;
42with System.Win32.Ext;     use System.Win32.Ext;
43
44with GNAT.OS_Lib;
45
46package body GNAT.Serial_Communications is
47
48   package OSC renames System.OS_Constants;
49
50   --  Common types
51
52   type Port_Data is new HANDLE;
53
54   C_Bits      : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
55   C_Parity    : constant array (Parity_Check) of Interfaces.C.unsigned :=
56                   (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY);
57   C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned :=
58                   (One => ONESTOPBIT, Two => TWOSTOPBITS);
59
60   -----------
61   -- Files --
62   -----------
63
64   procedure Raise_Error (Message : String; Error : DWORD := GetLastError);
65   pragma No_Return (Raise_Error);
66
67   -----------
68   -- Close --
69   -----------
70
71   procedure Close (Port : in out Serial_Port) is
72      procedure Unchecked_Free is
73        new Unchecked_Deallocation (Port_Data, Port_Data_Access);
74
75      Success : BOOL;
76
77   begin
78      if Port.H /= null then
79         Success := CloseHandle (HANDLE (Port.H.all));
80         Unchecked_Free (Port.H);
81
82         if Success = Win32.FALSE then
83            Raise_Error ("error closing the port");
84         end if;
85      end if;
86   end Close;
87
88   ----------
89   -- Name --
90   ----------
91
92   function Name (Number : Positive) return Port_Name is
93      N_Img : constant String := Positive'Image (Number);
94   begin
95      if Number > 9 then
96         return
97           Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last));
98      else
99         return
100           Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':');
101      end if;
102   end Name;
103
104   ----------
105   -- Open --
106   ----------
107
108   procedure Open
109     (Port : out Serial_Port;
110      Name : Port_Name)
111   is
112      C_Name  : constant String := String (Name) & ASCII.NUL;
113      Success : BOOL;
114      pragma Unreferenced (Success);
115
116   begin
117      if Port.H = null then
118         Port.H := new Port_Data;
119      else
120         Success := CloseHandle (HANDLE (Port.H.all));
121      end if;
122
123      Port.H.all := CreateFileA
124        (lpFileName            => C_Name (C_Name'First)'Address,
125         dwDesiredAccess       => GENERIC_READ or GENERIC_WRITE,
126         dwShareMode           => 0,
127         lpSecurityAttributes  => null,
128         dwCreationDisposition => OPEN_EXISTING,
129         dwFlagsAndAttributes  => 0,
130         hTemplateFile         => 0);
131
132      if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then
133         Raise_Error ("cannot open com port");
134      end if;
135   end Open;
136
137   -----------------
138   -- Raise_Error --
139   -----------------
140
141   procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
142   begin
143      raise Serial_Error with Message
144        & (if Error /= 0
145           then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')'
146           else "");
147   end Raise_Error;
148
149   ----------
150   -- Read --
151   ----------
152
153   overriding procedure Read
154     (Port   : in out Serial_Port;
155      Buffer : out Stream_Element_Array;
156      Last   : out Stream_Element_Offset)
157   is
158      Success   : BOOL;
159      Read_Last : aliased DWORD;
160
161   begin
162      if Port.H = null then
163         Raise_Error ("read: port not opened", 0);
164      end if;
165
166      Success :=
167        ReadFile
168          (hFile                => HANDLE (Port.H.all),
169           lpBuffer             => Buffer (Buffer'First)'Address,
170           nNumberOfBytesToRead => DWORD (Buffer'Length),
171           lpNumberOfBytesRead  => Read_Last'Access,
172           lpOverlapped         => null);
173
174      if Success = Win32.FALSE then
175         Raise_Error ("read error");
176      end if;
177
178      Last := Last_Index (Buffer'First, size_t (Read_Last));
179   end Read;
180
181   ---------
182   -- Set --
183   ---------
184
185   procedure Set
186     (Port      : Serial_Port;
187      Rate      : Data_Rate        := B9600;
188      Bits      : Data_Bits        := CS8;
189      Stop_Bits : Stop_Bits_Number := One;
190      Parity    : Parity_Check     := None;
191      Block     : Boolean          := True;
192      Local     : Boolean          := True;
193      Flow      : Flow_Control     := None;
194      Timeout   : Duration         := 10.0)
195   is
196      pragma Unreferenced (Local);
197
198      Success      : BOOL;
199      Com_Time_Out : aliased COMMTIMEOUTS;
200      Com_Settings : aliased DCB;
201
202   begin
203      if Port.H = null then
204         Raise_Error ("set: port not opened", 0);
205      end if;
206
207      Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access);
208
209      if Success = Win32.FALSE then
210         Success := CloseHandle (HANDLE (Port.H.all));
211         Port.H.all := 0;
212         Raise_Error ("set: cannot get comm state");
213      end if;
214
215      Com_Settings.BaudRate        := DWORD (Data_Rate_Value (Rate));
216      Com_Settings.fParity         := 1;
217      Com_Settings.fBinary         := Bits1 (System.Win32.TRUE);
218      Com_Settings.fOutxDsrFlow    := 0;
219      Com_Settings.fDsrSensitivity := 0;
220      Com_Settings.fDtrControl     := OSC.DTR_CONTROL_ENABLE;
221      Com_Settings.fInX            := 0;
222      Com_Settings.fRtsControl     := OSC.RTS_CONTROL_ENABLE;
223
224      case Flow is
225         when None =>
226            Com_Settings.fOutX        := 0;
227            Com_Settings.fOutxCtsFlow := 0;
228
229         when RTS_CTS =>
230            Com_Settings.fOutX        := 0;
231            Com_Settings.fOutxCtsFlow := 1;
232
233         when Xon_Xoff =>
234            Com_Settings.fOutX        := 1;
235            Com_Settings.fOutxCtsFlow := 0;
236      end case;
237
238      Com_Settings.fAbortOnError := 0;
239      Com_Settings.ByteSize      := BYTE (C_Bits (Bits));
240      Com_Settings.Parity        := BYTE (C_Parity (Parity));
241      Com_Settings.StopBits      := BYTE (C_Stop_Bits (Stop_Bits));
242
243      Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access);
244
245      if Success = Win32.FALSE then
246         Success := CloseHandle (HANDLE (Port.H.all));
247         Port.H.all := 0;
248         Raise_Error ("cannot set comm state");
249      end if;
250
251      --  Set the timeout status, to honor our spec with respect to read
252      --  timeouts. Always disconnect write timeouts.
253
254      --  Blocking reads - no timeout at all
255
256      if Block then
257         Com_Time_Out := (others => 0);
258
259      --  Non-blocking reads and null timeout - immediate return with what we
260      --  have - set ReadIntervalTimeout to MAXDWORD.
261
262      elsif Timeout = 0.0 then
263         Com_Time_Out :=
264           (ReadIntervalTimeout => DWORD'Last,
265            others              => 0);
266
267      --  Non-blocking reads with timeout - set total read timeout accordingly
268
269      else
270         Com_Time_Out :=
271           (ReadTotalTimeoutConstant => DWORD (1000 * Timeout),
272            others                   => 0);
273      end if;
274
275      Success :=
276        SetCommTimeouts
277          (hFile          => HANDLE (Port.H.all),
278           lpCommTimeouts => Com_Time_Out'Access);
279
280      if Success = Win32.FALSE then
281         Raise_Error ("cannot set the timeout");
282      end if;
283   end Set;
284
285   -----------
286   -- Write --
287   -----------
288
289   overriding procedure Write
290     (Port   : in out Serial_Port;
291      Buffer : Stream_Element_Array)
292   is
293      Success   : BOOL;
294      Temp_Last : aliased DWORD;
295
296   begin
297      if Port.H = null then
298         Raise_Error ("write: port not opened", 0);
299      end if;
300
301      Success :=
302        WriteFile
303          (hFile                  => HANDLE (Port.H.all),
304           lpBuffer               => Buffer'Address,
305           nNumberOfBytesToWrite  => DWORD (Buffer'Length),
306           lpNumberOfBytesWritten => Temp_Last'Access,
307           lpOverlapped           => null);
308
309      if Success = Win32.FALSE
310        or else Stream_Element_Offset (Temp_Last) /= Buffer'Length
311      then
312         Raise_Error ("failed to write data");
313      end if;
314   end Write;
315
316end GNAT.Serial_Communications;
317