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 | ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2021-2022, AdaCore --
-- --
-- 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.Strings.UTF_Encoding.Wide_Strings;
with Ada.Wide_Characters.Handling;
with Ada.Environment_Variables;
with GNATCOLL.String_Builders;
package body GNATCOLL.OS.Process_Types is
package UTF renames Ada.Strings.UTF_Encoding.Wide_Strings;
package SB renames GNATCOLL.String_Builders;
package Env_Vars renames Ada.Environment_Variables;
package WCH renames Ada.Wide_Characters.Handling;
Minimal_Env : Environ;
procedure Add_Minimal_Env (Env : in out Environ);
procedure Add_Minimal_Env (Env : in out Environ) is
begin
if Env_Vars.Exists ("SYSTEMROOT") then
WSLB.Append
(Env.Env, "SYSTEMROOT=" & Env_Vars.Value ("SYSTEMROOT"));
end if;
if Env_Vars.Exists ("SYSTEMDRIVE") then
WSLB.Append
(Env.Env, "SYSTEMDRIVE=" & Env_Vars.Value ("SYSTEMDRIVE"));
end if;
end Add_Minimal_Env;
----------
-- As_C --
----------
function As_C (Args : Arguments) return OS.C_WString is
begin
return WSB.As_C_WString (WSB.WString_Builder (Args));
end As_C;
function As_C (Env : Environ) return OS.C_WString is
begin
if Env.Inherited then
-- Returning a null environment will cause Win32 API to inherit the
-- current environment.
return Null_C_WString;
elsif WSLB.Length (Env.Env) = 0 then
return WSLB.As_C_WString (Minimal_Env.Env);
else
return WSLB.As_C_WString (Env.Env);
end if;
end As_C;
----------------
-- Deallocate --
----------------
procedure Deallocate (Args : in out Arguments) is
begin
WSB.Deallocate (WSB.WString_Builder (Args));
end Deallocate;
procedure Deallocate (Env : in out Environ) is
begin
WSLB.Deallocate (Env.Env);
Env.Inherited := True;
end Deallocate;
------------
-- Import --
------------
procedure Import (Env : in out Environ) is
procedure Import_Var (Name, Value : String);
procedure Import_Var (Name, Value : String) is
begin
Set_Variable (Env, Name, Value);
end Import_Var;
begin
Env_Vars.Iterate (Import_Var'Unrestricted_Access);
end Import;
-------------
-- Inherit --
-------------
procedure Inherit (Env : in out Environ) is
begin
Env.Inherited := True;
WSLB.Deallocate (Env.Env);
end Inherit;
procedure Set_Variable
(Env : in out Environ;
Name : UTF8.UTF_8_String;
Value : UTF8.UTF_8_String)
is
Entry_Prefix : constant Wide_String := UTF.Decode (Name & "=");
begin
-- First remove previous entry for variable Name.
if not Env.Inherited then
for J in reverse 1 .. WSLB.Length (Env.Env) loop
declare
El : constant Wide_String := WSLB.Element (Env.Env, J);
begin
if El'Length >= Entry_Prefix'Length and then
WCH.To_Lower
(El (El'First .. El'First + Entry_Prefix'Length - 1)) =
WCH.To_Lower (Entry_Prefix)
then
WSLB.Delete (Env.Env, J);
-- By construction we are sure the environment object cannot
-- contains twice an element starting with NAME= thus break
-- on first deletion
exit;
end if;
end;
end loop;
end if;
if WSLB.Length (Env.Env) = 0 then
-- On Windows SYSTEMROOT variable is always needed. So keep the
-- variable.
Add_Minimal_Env (Env);
end if;
-- Add new entry
WSLB.Append (Env.Env, Name & "=" & Value);
Env.Inherited := False;
end Set_Variable;
------------------
-- Add_Argument --
------------------
procedure Add_Argument
(Args : in out Arguments;
Arg : UTF8.UTF_8_String)
is
Quoted_Arg : SB.Static_String_Builder (Arg'Length * 2 + 3 + 1);
-- Quoted version of the argument
Quote_Needed : Boolean := False;
-- Will be set to True if we need to append the quoted version
-- of the argument (occurs when a tab or a space is present in
-- the argument.
begin
-- Starting quote
SB.Append (Quoted_Arg, '"');
for K in Arg'Range loop
if Arg (K) = '"' then
-- If a quote is found escape it with backslash. If it was
-- preceeded by backslashes then escape all of them.
declare
Index : Integer := K - 1;
begin
while Index >= Arg'First and then Arg (Index) = '\' loop
SB.Append (Quoted_Arg, '\');
Index := Index - 1;
end loop;
end;
SB.Append (Quoted_Arg, '\');
SB.Append (Quoted_Arg, '"');
elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then
-- This is a tab or a space, so the argument should be quoted
SB.Append (Quoted_Arg, Arg (K));
Quote_Needed := True;
else
-- Other characters
SB.Append (Quoted_Arg, Arg (K));
end if;
end loop;
-- Closing quote
SB.Append (Quoted_Arg, '"');
declare
Quoted_Arg_Str : constant String := SB.As_String (Quoted_Arg);
begin
-- If this is not the first argument add a space as separator
if WSB.Length (WSB.WString_Builder (Args)) > 0 then
WSB.Append (WSB.WString_Builder (Args), " ");
end if;
if Quote_Needed or else Arg'Length = 0 then
-- Empty arguments and arguments containing spaces and tab should
-- be quoted.
WSB.Append (WSB.WString_Builder (Args), Quoted_Arg_Str);
else
-- Other arguments can be appended unchanged to the command line
WSB.Append
(WSB.WString_Builder (Args),
Quoted_Arg_Str
(Quoted_Arg_Str'First + 1 .. Quoted_Arg_Str'Last - 1));
end if;
end;
end Add_Argument;
begin
Add_Minimal_Env (Minimal_Env);
end GNATCOLL.OS.Process_Types;
|