1
-------------------------------------------------------------------------------
3
-- <STRONG>Copyright © 2001, 2002 by Thomas Wolf.</STRONG>
5
-- This piece of software is free software; you can redistribute it and/or
6
-- modify it under the terms of the GNU General Public License as published
7
-- by the Free Software Foundation; either version 2, or (at your option)
8
-- any later version. This software is distributed in the hope that it will
9
-- be useful, but <EM>without any warranty</EM>; without even the implied
10
-- warranty of <EM>merchantability or fitness for a particular purpose.</EM>
11
-- See the GNU General Public License for more details. You should have
12
-- received a copy of the GNU General Public License with this distribution,
13
-- see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
14
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
18
-- As a special exception from the GPL, if other files instantiate generics
19
-- from this unit, or you link this unit with other files to produce an
20
-- executable, this unit does not by itself cause the resulting executable
21
-- to be covered by the GPL. This exception does not however invalidate any
22
-- other reasons why the executable file might be covered by the GPL.
26
-- Thomas Wolf (TW) <E_MAIL>
30
-- Operations for manipulating file names. The package is intended for
31
-- use on Windows or Unix systems. Upon elaboration, it tries to figure
32
-- out the host operating system by examining the @PATH@ environment
33
-- variable: if that contains Windows-looking pathes (i.e., a '\' is found
34
-- before a any '/'), it assumes it's being used on Windows. If, on the
35
-- other hand, it finds a '/' first, it assumes Unix. If it finds neither,
36
-- it uses @GNAT.Os_Lib.Directory_Separator@ as its directory separator.
37
-- (If you intend to use this package on a non-GNAT system, you'll have
38
-- to change the body of this package as appropriate.)
40
-- All operations in this package are pur string manipulation operations.
41
-- There are no file system operations involved.
49
-- 19-MAR-2002 TW Initial version.
50
-- 03-MAY-2002 TW Added 'Drive' and 'Node'; various minor corrections.
52
-------------------------------------------------------------------------------
54
pragma License (Modified_GPL);
56
with Util.Environment;
61
pragma Elaborate_All (Util.Environment);
62
pragma Elaborate_All (Util.Strings);
64
package body Util.Pathes is
69
-- [(\\Node\{\}|Drive_Letter:{\})]{Name\{\}}[Base_Name][.Extension]
70
-- where Name . and .. have special meanings.
73
-- [/{/}]{Name/{/}][Base_Name][.Extension]
74
-- where Name . and .. have special meanings.
77
-- [Disk:]["["[Name]{.Dir_Name}"]"][Base_Name][.Extension][;Version]
78
-- where Dir_Name . and "" have special meaning
81
-- Not sure. I think it went like this:
82
-- {Name:}[Base_Name][.Extension]
83
-- where Name : has a special meaning.
85
-- VMS and Mac are not done yet!
89
----------------------------------------------------------------------------
90
-- Internal operations:
92
function Determine_Host_Separator
95
Path : constant String := Util.Environment.Safe_Get ("PATH");
96
I : Natural := First_Index (Path, '\');
97
J : Natural := First_Index (Path, '/');
99
if I = 0 then I := Natural'Last; end if;
100
if J = 0 then J := Natural'Last; end if;
106
return GNAT.OS_Lib.Directory_Separator;
108
end Determine_Host_Separator;
110
Dir_Sep : constant Character := Determine_Host_Separator;
113
(Full_Name : in String;
114
Separator : in Character)
118
-- Needs revision for VMS!
119
if (Separator = '\' or else Separator = '/') and then
120
Full_Name'Last > Full_Name'First + 1 and then
121
Full_Name (Full_Name'First) = Separator and then
122
Full_Name (Full_Name'First + 1) = Separator
125
I : constant Natural :=
126
First_Index (Full_Name
127
(Full_Name'First + 2 .. Full_Name'Last),
131
return Full_Name'Last;
141
(Full_Name : in String;
142
Separator : in Character)
145
I : Natural := Node_End (Full_Name, Separator);
148
I := Full_Name'First;
150
if Full_Name (I) /= Separator then
156
if Separator = '\' and then
157
I + 1 <= Full_Name'Last and then
158
Is_In (Letters, Full_Name (I)) and then
159
Full_Name (I + 1) = ':'
163
-- Needs revision for VMS!
168
(Full_Name : in String;
169
Separator : in Character)
172
I : constant Natural := Node_End (Full_Name, Separator);
174
if I > 0 and then Full_Name (I) /= Separator then
177
return Natural'Max (Last_Index (Full_Name, Separator),
178
Drive_End (Full_Name, Separator));
181
----------------------------------------------------------------------------
183
function Directory_Separator
188
end Directory_Separator;
191
(Full_Name : in String;
192
Separator : in Character := Util.Pathes.Directory_Separator)
195
I : Natural := Path_End (Full_Name, Separator);
198
if I = 0 then I := Full_Name'First; else I := I + 1; end if;
199
J := Last_Index (Full_Name (I .. Full_Name'Last), '.');
203
return Full_Name (J + 1 .. Full_Name'Last);
208
(Full_Name : in String;
209
Separator : in Character := Directory_Separator)
212
I : constant Natural := Path_End (Full_Name, Separator);
214
if I = 0 then return Full_Name; end if;
215
return Full_Name (I + 1 .. Full_Name'Last);
219
(Full_Name : in String;
220
Separator : in Character := Directory_Separator)
223
I : Natural := Path_End (Full_Name, Separator);
226
if I = 0 then I := Full_Name'First; else I := I + 1; end if;
227
J := Last_Index (Full_Name (I .. Full_Name'Last), '.');
229
-- Also handles cases like ".cshrc".
230
return Full_Name (I .. Full_Name'Last);
232
return Full_Name (I .. J - 1);
237
(Full_Name : in String;
238
Separator : in Character := Directory_Separator)
241
I : constant Natural := Path_End (Full_Name, Separator);
243
if I = 0 then return ""; end if;
244
return Full_Name (Full_Name'First .. I);
248
(Full_Name : in String;
249
Separator : in Character := Directory_Separator)
252
I : Natural := Node_End (Full_Name, Separator);
254
if I = 0 then I := Full_Name'First; else I := I + 1; end if;
256
Full_Name (I .. Drive_End (Full_Name (I .. Full_Name'Last),
261
(Full_Name : in String;
262
Separator : in Character := Directory_Separator)
265
I : Natural := Node_End (Full_Name, Separator);
267
if I = 0 then I := Full_Name'First; else I := I + 1; end if;
268
return Drive_End (Full_Name (I .. Full_Name'Last), Separator) > 0;
272
(Full_Name : in String;
273
Separator : in Character := Directory_Separator)
277
return Full_Name (Full_Name'First .. Node_End (Full_Name, Separator));
281
(Full_Name : in String;
282
Separator : in Character := Directory_Separator)
286
return Node_End (Full_Name, Separator) > 0;
291
Separator : in Character := Directory_Separator)
295
if Path'Last < Path'First then return '.' & Separator; end if;
296
if Drive_End (Path, Separator) = Path'Last then
298
elsif Path (Path'Last) = Separator then
301
return Path & Separator;
307
Separator : in Character := Directory_Separator)
313
Separator : in Character)
316
-- 'Path' is a cleaned-up path!
321
if Path'Last = Path'First and then Path (Path'First) = Separator then
322
raise Path_Error; -- Root in an absolute path
323
elsif Path = '.' & Separator then
324
return ".." & Separator;
326
I := Last_Index (Path (Path'First .. Path'Last - 1), Separator);
328
-- "something/", return "./"
329
if Path (Path'First .. Path'Last - 1) = ".." then
330
-- Oops, we already had "../": return "../../".
332
elsif Path (Path'First .. Path'Last - 1) = "." then
333
-- We had "./", return "./../".
334
return Path & ".." & Separator;
336
return '.' & Separator;
339
if Path (I + 1 .. Path'Last - 1) = ".." then
340
-- We have only a sequence of "../": add one more.
341
return Path & ".." & Separator;
343
return Path (Path'First .. I);
348
P : constant String := Clean (Path, Separator);
352
I := Node_End (P, Separator);
353
if I = 0 then I := P'First; else I := I + 1; end if;
354
J := Drive_End (P (I .. P'Last), Separator);
357
return P & ".." & Separator;
359
return P (P'First .. J) &
360
Up (P (J + 1 .. P'Last), Separator);
363
if P (I) = Separator then
364
return P (P'First .. I - 1) &
365
Up (P (I .. P'Last), Separator);
367
-- Only a node name: cannot get the parent, for relative pathes
372
-- Neither node name nor drive:
373
return Up (P, Separator);
377
(Full_Name : in String;
378
Separator : in Character := Directory_Separator)
384
Separator : in Character)
387
Result : String (1 .. Path'Length + 1);
391
for I in Path'Range loop
392
Result (K) := Path (I);
393
if Path (I) = Separator then
394
if K > Result'First + 2 and then
395
Result (K - 1) = '.' and then
396
Result (K - 2) = '.' and then
397
Result (K - 3) = Separator
399
if K = Result'First + 3 then
400
-- A path cannot start with "/../"!
404
J : constant Natural :=
405
Last_Index (Result (Result'First .. K - 4),
409
if Result (J + 1 .. K - 4) = ".." then
410
-- We have "../../../", which is legal and can
411
-- occur only at the beginning!
417
if K - 4 = Result'First and then
418
Result (Result'First) = '.'
420
-- We have "./../", which should become "../".
421
Result (Result'First + 1) := '.';
422
Result (Result'First + 2) := Separator;
423
K := Result'First + 2;
424
elsif Result (Result'First .. K - 4) = ".." then
425
-- We have "../../" at the beginning!
428
-- We have "something/../", which should
430
Result (Result'First) := '.';
431
Result (Result'First + 1) := Separator;
432
K := Result'First + 1;
436
elsif K > Result'First + 1 and then
437
Result (K - 1) = '.' and then
438
Result (K - 2) = Separator
441
elsif K > Result'First and then
442
Result (K - 1) = Separator
444
-- Eliminate extraneous separators.
451
if K >= Result'First and then Result (K) /= Separator then
453
Result (K) := Separator;
455
return Result (Result'First .. K);
461
I := Node_End (Full_Name, Separator);
463
if Full_Name (I) /= Separator then
464
-- Only a node name, without terminating separator:
465
return Full_Name & Separator;
467
-- Skip multiple separators:
469
while J <= Full_Name'Last and then Full_Name (J) = Separator loop
473
return Clean (Full_Name (Full_Name'First .. I) &
474
Full_Name (J .. Full_Name'Last));
477
J := Drive_End (Full_Name, Separator);
479
return Full_Name (Full_Name'First .. J) &
480
Clean_It (Full_Name (J + 1 .. Full_Name'Last), Separator);
483
return Full_Name (Full_Name'First .. I - 1) &
484
Clean_It (Full_Name (I .. Full_Name'Last), Separator);
486
return Clean_It (Full_Name, Separator);
489
function Is_Absolute_Path
491
Separator : in Character := Directory_Separator)
495
if Name'Last < Name'First then return False; end if;
496
if Separator = ':' then
497
-- Mac? It's been a while, but if I remember correctly, it went
499
return Name (Name'First) /= ':';
501
-- Not Mac, i.e. Windows or Unix.
502
if Name (Name'First) = Separator then
505
if Drive_End (Name, Separator) > 0 then
510
end Is_Absolute_Path;
514
File_Name : in String;
515
Separator : in Character := Directory_Separator)
519
if Path'Last < Path'First then return File_Name; end if;
520
if File_Name'Last < File_Name'First then return Path; end if;
521
if Is_Absolute_Path (File_Name, Separator) then
524
return Normalize (Path, Separator) & File_Name;
527
function Replace_File_Name
528
(Full_Name : in String;
529
File_Name : in String;
530
Separator : in Character := Directory_Separator)
534
return Concat (Path (Full_Name, Separator), File_Name, Separator);
535
end Replace_File_Name;
537
function Replace_Extension
538
(Full_Name : in String;
539
Extension : in String;
540
Separator : in Character := Directory_Separator)
543
J : Natural := Path_End (Full_Name, Separator);
545
if Full_Name'Last < Full_Name'First or else J = Full_Name'Last then
549
I : constant Natural := Last_Index (Full_Name, '.');
551
if J = 0 then J := Full_Name'First; else J := J + 1; end if;
553
return Full_Name & '.' & Extension;
555
return Full_Name (Full_Name'First .. I) & Extension;
558
end Replace_Extension;
added
removed
util-pathes.adb
