File : mlib.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M L I B --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2014, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Ada.Characters.Handling; use Ada.Characters.Handling;
27 with Interfaces.C.Strings;
28 with System;
29
30 with Opt;
31 with Output; use Output;
32
33 with MLib.Utl; use MLib.Utl;
34
35 with Prj.Com;
36
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
38
39 package body MLib is
40
41 -------------------
42 -- Build_Library --
43 -------------------
44
45 procedure Build_Library
46 (Ofiles : Argument_List;
47 Output_File : String;
48 Output_Dir : String)
49 is
50 begin
51 if Opt.Verbose_Mode and not Opt.Quiet_Output then
52 Write_Line ("building a library...");
53 Write_Str (" make ");
54 Write_Line (Output_File);
55 end if;
56
57 Ar (Output_Dir &
58 "lib" & Output_File & ".a", Objects => Ofiles);
59 end Build_Library;
60
61 ------------------------
62 -- Check_Library_Name --
63 ------------------------
64
65 procedure Check_Library_Name (Name : String) is
66 begin
67 if Name'Length = 0 then
68 Prj.Com.Fail ("library name cannot be empty");
69 end if;
70
71 if Name'Length > Max_Characters_In_Library_Name then
72 Prj.Com.Fail ("illegal library name """
73 & Name
74 & """: too long");
75 end if;
76
77 if not Is_Letter (Name (Name'First)) then
78 Prj.Com.Fail ("illegal library name """
79 & Name
80 & """: should start with a letter");
81 end if;
82
83 for Index in Name'Range loop
84 if not Is_Alphanumeric (Name (Index)) then
85 Prj.Com.Fail ("illegal library name """
86 & Name
87 & """: should include only letters and digits");
88 end if;
89 end loop;
90 end Check_Library_Name;
91
92 --------------------
93 -- Copy_ALI_Files --
94 --------------------
95
96 procedure Copy_ALI_Files
97 (Files : Argument_List;
98 To : Path_Name_Type;
99 Interfaces : String_List)
100 is
101 Success : Boolean := False;
102 To_Dir : constant String := Get_Name_String (To);
103 Is_Interface : Boolean := False;
104
105 procedure Verbose_Copy (Index : Positive);
106 -- In verbose mode, output a message that the indexed file is copied
107 -- to the destination directory.
108
109 ------------------
110 -- Verbose_Copy --
111 ------------------
112
113 procedure Verbose_Copy (Index : Positive) is
114 begin
115 if Opt.Verbose_Mode then
116 Write_Str ("Copying """);
117 Write_Str (Files (Index).all);
118 Write_Str (""" to """);
119 Write_Str (To_Dir);
120 Write_Line ("""");
121 end if;
122 end Verbose_Copy;
123
124 -- Start of processing for Copy_ALI_Files
125
126 begin
127 if Interfaces'Length = 0 then
128
129 -- If there are no Interfaces, copy all the ALI files as is
130
131 for Index in Files'Range loop
132 Verbose_Copy (Index);
133 Set_Writable
134 (To_Dir &
135 Directory_Separator &
136 Base_Name (Files (Index).all));
137 Copy_File
138 (Files (Index).all,
139 To_Dir,
140 Success,
141 Mode => Overwrite,
142 Preserve => Preserve);
143
144 exit when not Success;
145 end loop;
146
147 else
148 -- Copy only the interface ALI file, and put the special indicator
149 -- "SL" on the P line.
150
151 for Index in Files'Range loop
152
153 declare
154 File_Name : String := Base_Name (Files (Index).all);
155
156 begin
157 Canonical_Case_File_Name (File_Name);
158
159 -- Check if this is one of the interface ALIs
160
161 Is_Interface := False;
162
163 for Index in Interfaces'Range loop
164 if File_Name = Interfaces (Index).all then
165 Is_Interface := True;
166 exit;
167 end if;
168 end loop;
169
170 -- If it is an interface ALI, copy line by line. Insert
171 -- the interface indication at the end of the P line.
172 -- Do not copy ALI files that are not Interfaces.
173
174 if Is_Interface then
175 Success := False;
176 Verbose_Copy (Index);
177 Set_Writable
178 (To_Dir &
179 Directory_Separator &
180 Base_Name (Files (Index).all));
181
182 declare
183 FD : File_Descriptor;
184 Len : Integer;
185 Actual_Len : Integer;
186 S : String_Access;
187 Curr : Natural;
188 P_Line_Found : Boolean;
189 Status : Boolean;
190
191 begin
192 -- Open the file
193
194 Name_Len := Files (Index)'Length;
195 Name_Buffer (1 .. Name_Len) := Files (Index).all;
196 Name_Len := Name_Len + 1;
197 Name_Buffer (Name_Len) := ASCII.NUL;
198
199 FD := Open_Read (Name_Buffer'Address, Binary);
200
201 if FD /= Invalid_FD then
202 Len := Integer (File_Length (FD));
203
204 -- ??? Why "+3" here
205
206 S := new String (1 .. Len + 3);
207
208 -- Read the file. This loop is probably not necessary
209 -- since on most (all?) targets, the whole file is
210 -- read in at once, but we have encountered systems
211 -- in the past where this was not true, and we retain
212 -- this loop in case we encounter that in the future.
213
214 Curr := S'First;
215 while Curr <= Len loop
216 Actual_Len := Read (FD, S (Curr)'Address, Len);
217
218 -- Exit if we could not read for some reason
219
220 exit when Actual_Len = 0;
221
222 Curr := Curr + Actual_Len;
223 end loop;
224
225 -- We are done with the input file, so we close it
226 -- ignoring any bad status.
227
228 Close (FD, Status);
229
230 P_Line_Found := False;
231
232 -- Look for the P line. When found, add marker SL
233 -- at the beginning of the P line.
234
235 for Index in 1 .. Len - 3 loop
236 if (S (Index) = ASCII.LF
237 or else
238 S (Index) = ASCII.CR)
239 and then S (Index + 1) = 'P'
240 then
241 S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
242 S (Index + 2 .. Index + 4) := " SL";
243 P_Line_Found := True;
244 exit;
245 end if;
246 end loop;
247
248 if P_Line_Found then
249
250 -- Create new modified ALI file
251
252 Name_Len := To_Dir'Length;
253 Name_Buffer (1 .. Name_Len) := To_Dir;
254 Name_Len := Name_Len + 1;
255 Name_Buffer (Name_Len) := Directory_Separator;
256 Name_Buffer
257 (Name_Len + 1 .. Name_Len + File_Name'Length) :=
258 File_Name;
259 Name_Len := Name_Len + File_Name'Length + 1;
260 Name_Buffer (Name_Len) := ASCII.NUL;
261
262 FD := Create_File (Name_Buffer'Address, Binary);
263
264 -- Write the modified text and close the newly
265 -- created file.
266
267 if FD /= Invalid_FD then
268 Actual_Len := Write (FD, S (1)'Address, Len + 3);
269
270 Close (FD, Status);
271
272 -- Set Success to True only if the newly
273 -- created file has been correctly written.
274
275 Success := Status and then Actual_Len = Len + 3;
276
277 if Success then
278
279 -- Set_Read_Only is used here, rather than
280 -- Set_Non_Writable, so that gprbuild can
281 -- he compiled with older compilers.
282
283 Set_Read_Only
284 (Name_Buffer (1 .. Name_Len - 1));
285 end if;
286 end if;
287 end if;
288 end if;
289 end;
290
291 -- This is not an interface ALI
292
293 else
294 Success := True;
295 end if;
296 end;
297
298 if not Success then
299 Prj.Com.Fail ("could not copy ALI files to library dir");
300 end if;
301 end loop;
302 end if;
303 end Copy_ALI_Files;
304
305 ----------------------
306 -- Create_Sym_Links --
307 ----------------------
308
309 procedure Create_Sym_Links
310 (Lib_Path : String;
311 Lib_Version : String;
312 Lib_Dir : String;
313 Maj_Version : String)
314 is
315 function Symlink
316 (Oldpath : System.Address;
317 Newpath : System.Address) return Integer;
318 pragma Import (C, Symlink, "__gnat_symlink");
319
320 Version_Path : String_Access;
321
322 Success : Boolean;
323 Result : Integer;
324 pragma Unreferenced (Success, Result);
325
326 begin
327 Version_Path := new String (1 .. Lib_Version'Length + 1);
328 Version_Path (1 .. Lib_Version'Length) := Lib_Version;
329 Version_Path (Version_Path'Last) := ASCII.NUL;
330
331 if Maj_Version'Length = 0 then
332 declare
333 Newpath : String (1 .. Lib_Path'Length + 1);
334 begin
335 Newpath (1 .. Lib_Path'Length) := Lib_Path;
336 Newpath (Newpath'Last) := ASCII.NUL;
337 Delete_File (Lib_Path, Success);
338 Result := Symlink (Version_Path (1)'Address, Newpath'Address);
339 end;
340
341 else
342 declare
343 Newpath1 : String (1 .. Lib_Path'Length + 1);
344 Maj_Path : constant String :=
345 Lib_Dir & Directory_Separator & Maj_Version;
346 Newpath2 : String (1 .. Maj_Path'Length + 1);
347 Maj_Ver : String (1 .. Maj_Version'Length + 1);
348
349 begin
350 Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
351 Newpath1 (Newpath1'Last) := ASCII.NUL;
352
353 Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
354 Newpath2 (Newpath2'Last) := ASCII.NUL;
355
356 Maj_Ver (1 .. Maj_Version'Length) := Maj_Version;
357 Maj_Ver (Maj_Ver'Last) := ASCII.NUL;
358
359 Delete_File (Maj_Path, Success);
360
361 Result := Symlink (Version_Path (1)'Address, Newpath2'Address);
362
363 Delete_File (Lib_Path, Success);
364
365 Result := Symlink (Maj_Ver'Address, Newpath1'Address);
366 end;
367 end if;
368 end Create_Sym_Links;
369
370 --------------------------------
371 -- Linker_Library_Path_Option --
372 --------------------------------
373
374 function Linker_Library_Path_Option return String_Access is
375
376 Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
377 pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
378 -- Pointer to string representing the native linker option which
379 -- specifies the path where the dynamic loader should find shared
380 -- libraries. Equal to null string if this system doesn't support it.
381
382 S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
383
384 begin
385 if S'Length = 0 then
386 return null;
387 else
388 return new String'(S);
389 end if;
390 end Linker_Library_Path_Option;
391
392 -------------------
393 -- Major_Id_Name --
394 -------------------
395
396 function Major_Id_Name
397 (Lib_Filename : String;
398 Lib_Version : String)
399 return String
400 is
401 Maj_Version : constant String := Lib_Version;
402 Last_Maj : Positive;
403 Last : Positive;
404 Ok_Maj : Boolean := False;
405
406 begin
407 Last_Maj := Maj_Version'Last;
408 while Last_Maj > Maj_Version'First loop
409 if Maj_Version (Last_Maj) in '0' .. '9' then
410 Last_Maj := Last_Maj - 1;
411
412 else
413 Ok_Maj := Last_Maj /= Maj_Version'Last and then
414 Maj_Version (Last_Maj) = '.';
415
416 if Ok_Maj then
417 Last_Maj := Last_Maj - 1;
418 end if;
419
420 exit;
421 end if;
422 end loop;
423
424 if Ok_Maj then
425 Last := Last_Maj;
426 while Last > Maj_Version'First loop
427 if Maj_Version (Last) in '0' .. '9' then
428 Last := Last - 1;
429
430 else
431 Ok_Maj := Last /= Last_Maj and then
432 Maj_Version (Last) = '.';
433
434 if Ok_Maj then
435 Last := Last - 1;
436 Ok_Maj :=
437 Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
438 end if;
439
440 exit;
441 end if;
442 end loop;
443 end if;
444
445 if Ok_Maj then
446 return Maj_Version (Maj_Version'First .. Last_Maj);
447 else
448 return "";
449 end if;
450 end Major_Id_Name;
451
452 -------------------------------
453 -- Separate_Run_Path_Options --
454 -------------------------------
455
456 function Separate_Run_Path_Options return Boolean is
457 Separate_Paths : Boolean;
458 for Separate_Paths'Size use Character'Size;
459 pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options");
460 begin
461 return Separate_Paths;
462 end Separate_Run_Path_Options;
463
464 end MLib;