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 | with AAA.Debug;
with Ada.Numerics.Discrete_Random;
with Ada.Unchecked_Deallocation;
with GNAT.OS_Lib;
package body AAA.Filesystem is
-------------
-- Is_File --
-------------
function Is_File (Path : String) return Boolean
is (GNAT.OS_Lib.Is_Regular_File (Path));
---------------
-- Is_Folder --
---------------
function Is_Folder (Path : String) return Boolean
is (GNAT.OS_Lib.Is_Directory (Path));
------------------------
-- Backup_If_Existing --
------------------------
procedure Backup_If_Existing (File : String;
Base_Dir : String := "")
is
use Ada.Directories;
Dst : constant String :=
(if Base_Dir /= ""
then Compose (Base_Dir, Simple_Name (File) & ".prev")
else File & ".prev");
begin
if Exists (File) then
if not Exists (Base_Dir) then
Create_Directory (Base_Dir);
end if;
Copy_File (File, Dst, "mode=overwrite");
end if;
end Backup_If_Existing;
----------------------
-- Ensure_Deletable --
----------------------
procedure Ensure_Deletable (Path : String) is
use Ada.Directories;
use GNAT;
OK : Boolean := False;
Args : OS_Lib.Argument_List_Access;
begin
if Exists (Path) and then
Kind (Path) = Directory and then
OS_Lib.Directory_Separator = '\'
then
Args := OS_Lib.Argument_String_To_List ("-R /D /S " & Path & "\*");
OS_Lib.Spawn ("attrib", Args.all, OK);
OS_Lib.Free (Args);
if not OK then
raise Program_Error with "failed to change attributes of " & Path;
end if;
end if;
end Ensure_Deletable;
----------------------------
-- Remove_Folder_If_Empty --
----------------------------
procedure Remove_Folder_If_Empty (Path : String) is
use Ada.Directories;
begin
Ada.Directories.Delete_Directory (Path);
exception
when Name_Error | Use_Error =>
null;
end Remove_Folder_If_Empty;
-------------------
-- Traverse_Tree --
-------------------
procedure Traverse_Tree (Start : String;
Doing : access procedure
(Item : Ada.Directories.Directory_Entry_Type;
Stop : in out Boolean);
Recurse : Boolean := False)
is
use Ada.Directories;
procedure Go_Down (Item : Directory_Entry_Type) is
Stop : Boolean := False;
begin
if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
Doing (Item, Stop);
if Stop then
return;
end if;
if Recurse and then Kind (Item) = Directory then
Traverse_Tree (Compose (Start, Simple_Name (Item)),
Doing, Recurse);
end if;
end if;
end Go_Down;
begin
Search (Start,
"",
(Directory => True, Ordinary_File => True, others => False),
Go_Down'Access);
end Traverse_Tree;
--------------
-- New_Name --
--------------
function New_Name (In_Folder : String := ".") return Temp_File
is
subtype Valid_Character is Character range 'a' .. 'z';
package Char_Random is new
Ada.Numerics.Discrete_Random (Valid_Character);
Gen : Char_Random.Generator;
begin
return Result : Temp_File := (Ada.Finalization.Limited_Controlled with
Name_Len => 12,
Folder_Len => In_Folder'Length,
Keep => <>,
Name => "aaa-XXXX.tmp",
Folder => In_Folder)
do
Char_Random.Reset (Gen);
for I in 5 .. 8 loop
Result.Name (I) := Char_Random.Random (Gen);
end loop;
end return;
end New_Name;
--------------
-- Filename --
--------------
function Filename (This : Temp_File) return String
is (Ada.Directories.Compose
(Ada.Directories.Full_Name (This.Folder), This.Name));
----------
-- Keep --
----------
procedure Keep (This : in out Temp_File) is
begin
This.Keep := True;
end Keep;
--------------
-- Finalize --
--------------
overriding
procedure Finalize (This : in out Temp_File) is
use Ada.Directories;
begin
if This.Keep then
return;
end if;
-- Force writability of folder when in Windows, as some tools (e.g. git)
-- that create read-only files will cause a Use_Error
Ensure_Deletable (This.Filename);
if Exists (This.Filename) then
if Kind (This.Filename) = Ordinary_File then
Delete_File (This.Filename);
elsif Kind (This.Filename) = Directory then
Delete_Tree (This.Filename);
end if;
end if;
exception
when E : others =>
Debug.Put_Exception (E);
end Finalize;
---------------
-- With_Name --
---------------
function With_Name (Name : String) return Temp_File is
(Temp_File'
(Ada.Finalization.Limited_Controlled with
Name_Len => Name'Length,
Name => Name,
Folder_Len => 1,
Folder => ".",
Keep => <>));
--------------
-- REPLACER --
--------------
-------------------
-- Editable_Name --
-------------------
function Editable_Name (This : Replacer) return String
is (This.Temp_Copy.Filename);
---------------------
-- New_Replacement --
---------------------
function New_Replacement (File : String;
Backup : Boolean := True;
Backup_Dir : String := "";
Allow_No_Original : Boolean := False)
return Replacer
is
Backup_To : constant String :=
(if Backup_Dir /= ""
then Backup_Dir
else Ada.Directories.Containing_Directory (File));
begin
return This : constant Replacer :=
(Ada.Finalization.Limited_Controlled with
Length => File'Length,
Backup_Len => Backup_To'Length,
Original => File,
Backup => Backup,
Backup_Dir => Backup_To,
Temp_Copy => new Temp_File'(New_Name (In_Folder => Backup_To)))
do
if Is_File (File) then
Ada.Directories.Copy_File (File, This.Temp_Copy.Filename);
elsif not Allow_No_Original then
raise Program_Error
with "Invalid original file for replacement: " & File;
end if;
end return;
end New_Replacement;
-------------
-- Replace --
-------------
procedure Replace (This : in out Replacer) is
begin
if This.Backup then
Backup_If_Existing (This.Original, This.Backup_Dir);
end if;
Ada.Directories.Copy_File (This.Editable_Name, This.Original);
-- The temporary copy will be cleaned up by This.Temp_Copy finalization
end Replace;
--------------
-- Finalize --
--------------
overriding procedure Finalize (This : in out Replacer) is
procedure Free is
new Ada.Unchecked_Deallocation (Temp_File, Temp_File_Access);
begin
Free (This.Temp_Copy);
exception
when E : others =>
Debug.Put_Exception (E);
end Finalize;
end AAA.Filesystem;
|