1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355 | -----------------------------------------------------------------------
-- util-system-os -- Windows system operations
-- Copyright (C) 2011, 2012, 2015, 2018, 2019, 2021, 2022 Stephane Carrez
-- Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;
with Util.Systems.Constants;
-- The <b>Util.Systems.Os</b> package defines various types and operations which are specific
-- to the OS (Windows).
package Util.Systems.Os is
-- The directory separator.
Directory_Separator : constant Character := '\';
-- The path separator.
Path_Separator : constant Character := ';';
-- The line ending separator.
Line_Separator : constant String := "" & ASCII.CR & ASCII.LF;
-- Defines several windows specific types.
type BOOL is mod 8;
type WORD is new Interfaces.C.short;
type DWORD is new Interfaces.C.unsigned_long;
type PDWORD is access all DWORD;
for PDWORD'Size use Standard'Address_Size;
type Process_Identifier is new Integer;
function Get_Last_Error return Integer
with Import => True, Convention => Stdcall, Link_Name => "GetLastError";
function Errno return Integer
with Import => True, Convention => Stdcall, Link_Name => "GetLastError";
-- Some useful error codes (See Windows document "System Error Codes (0-499)").
ERROR_BROKEN_PIPE : constant Integer := 109;
-- ------------------------------
-- Handle
-- ------------------------------
-- The windows HANDLE is defined as a void* in the C API.
subtype HANDLE is Util.Systems.Types.HANDLE;
use type Util.Systems.Types.HANDLE;
INVALID_HANDLE_VALUE : constant HANDLE := -1;
type PHANDLE is access all HANDLE;
for PHANDLE'Size use Standard'Address_Size;
function Wait_For_Single_Object (H : in HANDLE;
Time : in DWORD) return DWORD
with Import => True, Convention => Stdcall, Link_Name => "WaitForSingleObject";
type Security_Attributes is record
Length : DWORD;
Security_Descriptor : System.Address;
Inherit : Interfaces.C.int := 0;
end record;
type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;
-- ------------------------------
-- File operations
-- ------------------------------
subtype File_Type is Util.Systems.Types.File_Type;
NO_FILE : constant File_Type := 0;
STD_INPUT_HANDLE : constant DWORD := 16#fffffff6#;
STD_OUTPUT_HANDLE : constant DWORD := 16#fffffff5#;
STD_ERROR_HANDLE : constant DWORD := 16#fffffff4#;
-- These values are specific to Linux.
O_RDONLY : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
O_WRONLY : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
O_RDWR : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
O_CREAT : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
O_EXCL : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
O_TRUNC : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
O_APPEND : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;
function Get_Std_Handle (Kind : in DWORD) return File_Type
with Import => True, Convention => Stdcall, Link_Name => "GetStdHandle";
function STDIN_FILENO return File_Type
is (Get_Std_Handle (STD_INPUT_HANDLE));
function STDOUT_FILENO return File_Type
is (Get_Std_Handle (STD_OUTPUT_HANDLE));
function STDERR_FILENO return File_Type
is (Get_Std_Handle (STD_ERROR_HANDLE));
function Close_Handle (Fd : in File_Type) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "CloseHandle";
function Duplicate_Handle (SourceProcessHandle : in HANDLE;
SourceHandle : in HANDLE;
TargetProcessHandle : in HANDLE;
TargetHandle : in PHANDLE;
DesiredAccess : in DWORD;
InheritHandle : in BOOL;
Options : in DWORD) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "DuplicateHandle";
function Read_File (Fd : in File_Type;
Buf : in System.Address;
Size : in DWORD;
Result : in PDWORD;
Overlap : in System.Address) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "ReadFile";
function Write_File (Fd : in File_Type;
Buf : in System.Address;
Size : in DWORD;
Result : in PDWORD;
Overlap : in System.Address) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "WriteFile";
function Create_Pipe (Read_Handle : in PHANDLE;
Write_Handle : in PHANDLE;
Attributes : in LPSECURITY_ATTRIBUTES;
Buf_Size : in DWORD) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "CreatePipe";
subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
subtype PBYTE is Interfaces.C.Strings.chars_ptr;
subtype Ptr is Interfaces.C.Strings.chars_ptr;
subtype LPCTSTR is System.Address;
subtype LPTSTR is System.Address;
subtype LPVOID is System.Address;
type CommandPtr is access all Interfaces.C.wchar_array;
NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;
type FileTime is record
dwLowDateTime : DWORD;
dwHighDateTime : DWORD;
end record;
type LPFILETIME is access all FileTime;
function To_Time (Time : in FileTime) return Util.Systems.Types.Time_Type;
type Startup_Info is record
cb : DWORD := 0;
lpReserved : LPWSTR := NULL_STR;
lpDesktop : LPWSTR := NULL_STR;
lpTitle : LPWSTR := NULL_STR;
dwX : DWORD := 0;
dwY : DWORD := 0;
dwXsize : DWORD := 0;
dwYsize : DWORD := 0;
dwXCountChars : DWORD := 0;
dwYCountChars : DWORD := 0;
dwFillAttribute : DWORD := 0;
dwFlags : DWORD := 0;
wShowWindow : WORD := 0;
cbReserved2 : WORD := 0;
lpReserved2 : PBYTE := Interfaces.C.Strings.Null_Ptr;
hStdInput : HANDLE := 0;
hStdOutput : HANDLE := 0;
hStdError : HANDLE := 0;
end record;
type Startup_Info_Access is access all Startup_Info;
type PROCESS_INFORMATION is record
hProcess : HANDLE := NO_FILE;
hThread : HANDLE := NO_FILE;
dwProcessId : DWORD;
dwThreadId : DWORD;
end record;
type Process_Information_Access is access all PROCESS_INFORMATION;
function Get_Current_Process return HANDLE
with Import => True, Convention => Stdcall, Link_Name => "GetCurrentProcess";
function Get_Exit_Code_Process (Proc : in HANDLE;
Code : in PDWORD) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "GetExitCodeProcess";
function Create_Process (Name : in LPCTSTR;
Command : in System.Address;
Process_Attributes : in LPSECURITY_ATTRIBUTES;
Thread_Attributes : in LPSECURITY_ATTRIBUTES;
Inherit_Handles : in BOOL;
Creation_Flags : in DWORD;
Environment : in LPTSTR;
Directory : in LPCTSTR;
Startup_Info : in Startup_Info_Access;
Process_Info : in Process_Information_Access)
return Integer
with Import => True, Convention => Stdcall, Link_Name => "CreateProcessW";
-- Terminate the windows process and all its threads.
function Terminate_Process (Proc : in HANDLE;
Code : in DWORD) return Integer
with Import => True, Convention => Stdcall, Link_Name => "TerminateProcess";
function Sys_Stat (Path : in LPWSTR;
Stat : access Util.Systems.Types.Stat_Type) return Integer
with Import => True, Convention => Stdcall, Link_Name => "_stat64";
function Sys_Fstat (Fs : in File_Type;
Stat : access Util.Systems.Types.Stat_Type) return Integer;
function Sys_Lstat (Path : in String;
Stat : access Util.Systems.Types.Stat_Type) return Integer
with Import => True, Convention => Stdcall, Link_Name => "_stat64";
function Sys_Lseek (Fs : in File_Type;
Offset : in Util.Systems.Types.off_t;
Mode : in Util.Systems.Types.Seek_Mode)
return Util.Systems.Types.off_t;
FILE_SHARE_WRITE : constant DWORD := 16#02#;
FILE_SHARE_READ : constant DWORD := 16#01#;
GENERIC_READ : constant DWORD := 16#80000000#;
GENERIC_WRITE : constant DWORD := 16#40000000#;
CREATE_NEW : constant DWORD := 1;
CREATE_ALWAYS : constant DWORD := 2;
OPEN_EXISTING : constant DWORD := 3;
OPEN_ALWAYS : constant DWORD := 4;
TRUNCATE_EXISTING : constant DWORD := 5;
FILE_APPEND_DATA : constant DWORD := 4;
FILE_ATTRIBUTE_ARCHIVE : constant DWORD := 16#20#;
FILE_ATTRIBUTE_HIDDEN : constant DWORD := 16#02#;
FILE_ATTRIBUTE_NORMAL : constant DWORD := 16#80#;
FILE_ATTRIBUTE_READONLY : constant DWORD := 16#01#;
FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;
function Create_File (Name : in LPCTSTR;
Desired_Access : in DWORD;
Share_Mode : in DWORD;
Attributes : in LPSECURITY_ATTRIBUTES;
Creation : in DWORD;
Flags : in DWORD;
Template_File : HANDLE) return HANDLE
with Import => True, Convention => Stdcall, Link_Name => "CreateFileW";
function Replace_File (Replaced_File : in LPCTSTR;
Replacement_File : in LPCTSTR;
Backup_File : in LPCTSTR;
Replace_Flags : in DWORD;
Exclude : in LPCTSTR;
Reserved : in LPCTSTR) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "ReplaceFileW";
function Move_File (Existing_File : in LPCTSTR;
New_File : in LPCTSTR;
Flags : in DWORD) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "MoveFileExW";
function Get_Full_Pathname (Path : in LPCTSTR;
Length : in DWORD;
Buffer : in LPCTSTR;
Ptr : in LPCSTR) return DWORD
with Import => True, Convention => Stdcall, Link_Name => "GetFullPathNameW";
-- Close a file
function Sys_Close (Fd : in File_Type) return Integer;
-- Open a file
function Sys_Open (Path : in Ptr;
Flags : in Interfaces.C.int;
Mode : in Util.Systems.Types.mode_t) return File_Type;
function Sys_Ftruncate (Fs : in File_Type;
Length : in Util.Systems.Types.off_t) return Integer;
function Sys_Fchmod (Fd : in File_Type;
Mode : in Util.Systems.Types.mode_t) return Integer;
-- Change permission of a file.
function Sys_Chmod (Path : in Ptr;
Mode : in Util.Systems.Types.mode_t) return Integer
with Import => True, Convention => Stdcall, Link_Name => "_chmod";
function Sys_Realpath (S : in Ptr;
R : in Ptr) return Ptr;
function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
with Import => True, Convention => Stdcall, Link_Name => "strerror";
function Sys_GetHandleInformation (Fd : in HANDLE; Flags : access DWORD) return BOOL
with Import => True, Convention => Stdcall, Link_Name => "GetHandleInformation";
type Wchar_Ptr is access all Interfaces.C.wchar_array;
function To_WSTR (Value : in String) return Wchar_Ptr;
procedure Free is
new Ada.Unchecked_Deallocation (Object => Interfaces.C.wchar_array,
Name => Wchar_Ptr);
-- Rename a file (the Ada.Directories.Rename does not allow to use
-- the Unix atomic file rename!)
function Sys_Rename (Oldpath : in String;
Newpath : in String) return Integer;
function Sys_Unlink (Path : in String) return Integer
with Import => True, Convention => C, Link_Name => "unlink";
type DIR is new System.Address;
Null_Dir : constant DIR := DIR (System.Null_Address);
-- Equivalent to Posix opendir (3) but handles some portability issues.
-- We could use opendir, readdir_r and closedir but the __gnat_* alternative
-- solves
function Opendir (Directory : in String) return DIR
with Import, External_Name => "__gnat_opendir", Convention => C;
function Readdir (Directory : in DIR;
Buffer : in System.Address;
Last : not null access Integer) return System.Address
with Import, External_Name => "__gnat_readdir", Convention => C;
function Closedir (Directory : in DIR) return Integer
with Import, External_Name => "__gnat_closedir", Convention => C;
private
-- kernel32 is used on Windows32 as well as Windows64.
pragma Linker_Options ("-lkernel32");
end Util.Systems.Os;
|