OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-direct.adb] - Blame information for rev 410

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--                      A D A . D I R E C T O R I E S                       --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --
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.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Ada.Calendar;               use Ada.Calendar;
33
with Ada.Calendar.Formatting;    use Ada.Calendar.Formatting;
34
with Ada.Directories.Validity;   use Ada.Directories.Validity;
35
with Ada.Strings.Maps;
36
with Ada.Strings.Fixed;
37
with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;
38
with Ada.Unchecked_Conversion;
39
with Ada.Unchecked_Deallocation;
40
with Ada.Characters.Handling;    use Ada.Characters.Handling;
41
 
42
with System.CRTL;                use System.CRTL;
43
with System.OS_Lib;              use System.OS_Lib;
44
with System.Regexp;              use System.Regexp;
45
 
46
with System;
47
 
48
package body Ada.Directories is
49
 
50
   Filename_Max : constant Integer := 1024;
51
   --  1024 is the value of FILENAME_MAX in stdio.h
52
 
53
   type Dir_Type_Value is new System.Address;
54
   --  This is the low-level address directory structure as returned by the C
55
   --  opendir routine.
56
 
57
   No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);
58
 
59
   Dir_Separator : constant Character;
60
   pragma Import (C, Dir_Separator, "__gnat_dir_separator");
61
   --  Running system default directory separator
62
 
63
   Dir_Seps : constant Ada.Strings.Maps.Character_Set :=
64
                Ada.Strings.Maps.To_Set ("/\");
65
   --  UNIX and DOS style directory separators
66
 
67
   Max_Path : Integer;
68
   pragma Import (C, Max_Path, "__gnat_max_path_len");
69
   --  The maximum length of a path
70
 
71
   type Search_Data is record
72
      Is_Valid      : Boolean := False;
73
      Name          : Unbounded_String;
74
      Pattern       : Regexp;
75
      Filter        : Filter_Type;
76
      Dir           : Dir_Type_Value := No_Dir;
77
      Entry_Fetched : Boolean := False;
78
      Dir_Entry     : Directory_Entry_Type;
79
   end record;
80
   --  The current state of a search
81
 
82
   Empty_String : constant String := (1 .. 0 => ASCII.NUL);
83
   --  Empty string, returned by function Extension when there is no extension
84
 
85
   procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
86
 
87
   procedure Close (Dir : Dir_Type_Value);
88
 
89
   function File_Exists (Name : String) return Boolean;
90
   --  Returns True if the named file exists
91
 
92
   procedure Fetch_Next_Entry (Search : Search_Type);
93
   --  Get the next entry in a directory, setting Entry_Fetched if successful
94
   --  or resetting Is_Valid if not.
95
 
96
   ---------------
97
   -- Base_Name --
98
   ---------------
99
 
100
   function Base_Name (Name : String) return String is
101
      Simple : constant String := Simple_Name (Name);
102
      --  Simple'First is guaranteed to be 1
103
 
104
   begin
105
      --  Look for the last dot in the file name and return the part of the
106
      --  file name preceding this last dot. If the first dot is the first
107
      --  character of the file name, the base name is the empty string.
108
 
109
      for Pos in reverse Simple'Range loop
110
         if Simple (Pos) = '.' then
111
            return Simple (1 .. Pos - 1);
112
         end if;
113
      end loop;
114
 
115
      --  If there is no dot, return the complete file name
116
 
117
      return Simple;
118
   end Base_Name;
119
 
120
   -----------
121
   -- Close --
122
   -----------
123
 
124
   procedure Close (Dir : Dir_Type_Value) is
125
      Discard : Integer;
126
      pragma Warnings (Off, Discard);
127
 
128
      function closedir (directory : DIRs) return Integer;
129
      pragma Import (C, closedir, "__gnat_closedir");
130
 
131
   begin
132
      Discard := closedir (DIRs (Dir));
133
   end Close;
134
 
135
   -------------
136
   -- Compose --
137
   -------------
138
 
139
   function Compose
140
     (Containing_Directory : String := "";
141
      Name                 : String;
142
      Extension            : String := "") return String
143
   is
144
      Result : String (1 .. Containing_Directory'Length +
145
                              Name'Length + Extension'Length + 2);
146
      Last   : Natural;
147
 
148
   begin
149
      --  First, deal with the invalid cases
150
 
151
      if Containing_Directory /= ""
152
        and then not Is_Valid_Path_Name (Containing_Directory)
153
      then
154
         raise Name_Error with
155
           "invalid directory path name """ & Containing_Directory & '"';
156
 
157
      elsif
158
        Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
159
      then
160
         raise Name_Error with
161
           "invalid simple name """ & Name & '"';
162
 
163
      elsif Extension'Length /= 0
164
        and then not Is_Valid_Simple_Name (Name & '.' & Extension)
165
      then
166
         raise Name_Error with
167
           "invalid file name """ & Name & '.' & Extension & '"';
168
 
169
      --  This is not an invalid case so build the path name
170
 
171
      else
172
         Last := Containing_Directory'Length;
173
         Result (1 .. Last) := Containing_Directory;
174
 
175
         --  Add a directory separator if needed
176
 
177
         if Last /= 0 and then Result (Last) /= Dir_Separator then
178
            Last := Last + 1;
179
            Result (Last) := Dir_Separator;
180
         end if;
181
 
182
         --  Add the file name
183
 
184
         Result (Last + 1 .. Last + Name'Length) := Name;
185
         Last := Last + Name'Length;
186
 
187
         --  If extension was specified, add dot followed by this extension
188
 
189
         if Extension'Length /= 0 then
190
            Last := Last + 1;
191
            Result (Last) := '.';
192
            Result (Last + 1 .. Last + Extension'Length) := Extension;
193
            Last := Last + Extension'Length;
194
         end if;
195
 
196
         return Result (1 .. Last);
197
      end if;
198
   end Compose;
199
 
200
   --------------------------
201
   -- Containing_Directory --
202
   --------------------------
203
 
204
   function Containing_Directory (Name : String) return String is
205
   begin
206
      --  First, the invalid case
207
 
208
      if not Is_Valid_Path_Name (Name) then
209
         raise Name_Error with "invalid path name """ & Name & '"';
210
 
211
      else
212
         declare
213
            --  We need to resolve links because of A.16(47), since we must not
214
            --  return alternative names for files.
215
 
216
            Norm    : constant String := Normalize_Pathname (Name);
217
            Last_DS : constant Natural :=
218
                        Strings.Fixed.Index
219
                          (Name, Dir_Seps, Going => Strings.Backward);
220
 
221
         begin
222
            if Last_DS = 0 then
223
 
224
               --  There is no directory separator, returns current working
225
               --  directory.
226
 
227
               return Current_Directory;
228
 
229
            --  If Name indicates a root directory, raise Use_Error, because
230
            --  it has no containing directory.
231
 
232
            elsif Norm = "/"
233
              or else
234
                (Windows
235
                 and then
236
                   (Norm = "\"
237
                    or else
238
                      (Norm'Length = 3
239
                        and then Norm (Norm'Last - 1 .. Norm'Last) = ":\"
240
                        and then (Norm (Norm'First) in 'a' .. 'z'
241
                                   or else Norm (Norm'First) in 'A' .. 'Z'))))
242
            then
243
               raise Use_Error with
244
                 "directory """ & Name & """ has no containing directory";
245
 
246
            else
247
               declare
248
                  Last   : Positive := Last_DS - Name'First + 1;
249
                  Result : String (1 .. Last);
250
 
251
               begin
252
                  Result := Name (Name'First .. Last_DS);
253
 
254
                  --  Remove any trailing directory separator, except as the
255
                  --  first character or the first character following a drive
256
                  --  number on Windows.
257
 
258
                  while Last > 1 loop
259
                     exit when
260
                       Result (Last) /= '/'
261
                         and then
262
                       Result (Last) /= Directory_Separator;
263
 
264
                     exit when Windows
265
                       and then Last = 3
266
                       and then Result (2) = ':'
267
                       and then
268
                         (Result (1) in 'A' .. 'Z'
269
                           or else
270
                          Result (1) in 'a' .. 'z');
271
 
272
                     Last := Last - 1;
273
                  end loop;
274
 
275
                  --  Special case of current directory, identified by "."
276
 
277
                  if Last = 1 and then Result (1) = '.' then
278
                     return Current_Directory;
279
 
280
                  --  Special case of "..": the current directory may be a root
281
                  --  directory.
282
 
283
                  elsif Last = 2 and then Result (1 .. 2) = ".." then
284
                     return Containing_Directory (Current_Directory);
285
 
286
                  else
287
                     return Result (1 .. Last);
288
                  end if;
289
               end;
290
            end if;
291
         end;
292
      end if;
293
   end Containing_Directory;
294
 
295
   ---------------
296
   -- Copy_File --
297
   ---------------
298
 
299
   procedure Copy_File
300
     (Source_Name : String;
301
      Target_Name : String;
302
      Form        : String := "")
303
   is
304
      pragma Unreferenced (Form);
305
      Success : Boolean;
306
 
307
   begin
308
      --  First, the invalid cases
309
 
310
      if not Is_Valid_Path_Name (Source_Name) then
311
         raise Name_Error with
312
           "invalid source path name """ & Source_Name & '"';
313
 
314
      elsif not Is_Valid_Path_Name (Target_Name) then
315
         raise Name_Error with
316
           "invalid target path name """ & Target_Name & '"';
317
 
318
      elsif not Is_Regular_File (Source_Name) then
319
         raise Name_Error with '"' & Source_Name & """ is not a file";
320
 
321
      elsif Is_Directory (Target_Name) then
322
         raise Use_Error with "target """ & Target_Name & """ is a directory";
323
 
324
      else
325
         --  The implementation uses System.OS_Lib.Copy_File, with parameters
326
         --  suitable for all platforms.
327
 
328
         Copy_File (Source_Name, Target_Name, Success, Overwrite, None);
329
 
330
         if not Success then
331
            raise Use_Error with "copy of """ & Source_Name & """ failed";
332
         end if;
333
      end if;
334
   end Copy_File;
335
 
336
   ----------------------
337
   -- Create_Directory --
338
   ----------------------
339
 
340
   procedure Create_Directory
341
     (New_Directory : String;
342
      Form          : String := "")
343
   is
344
      pragma Unreferenced (Form);
345
 
346
      C_Dir_Name : constant String := New_Directory & ASCII.NUL;
347
 
348
      function mkdir (Dir_Name : String) return Integer;
349
      pragma Import (C, mkdir, "__gnat_mkdir");
350
 
351
   begin
352
      --  First, the invalid case
353
 
354
      if not Is_Valid_Path_Name (New_Directory) then
355
         raise Name_Error with
356
           "invalid new directory path name """ & New_Directory & '"';
357
 
358
      else
359
         if mkdir (C_Dir_Name) /= 0 then
360
            raise Use_Error with
361
              "creation of new directory """ & New_Directory & """ failed";
362
         end if;
363
      end if;
364
   end Create_Directory;
365
 
366
   -----------------
367
   -- Create_Path --
368
   -----------------
369
 
370
   procedure Create_Path
371
     (New_Directory : String;
372
      Form          : String := "")
373
   is
374
      pragma Unreferenced (Form);
375
 
376
      New_Dir : String (1 .. New_Directory'Length + 1);
377
      Last    : Positive := 1;
378
 
379
   begin
380
      --  First, the invalid case
381
 
382
      if not Is_Valid_Path_Name (New_Directory) then
383
         raise Name_Error with
384
           "invalid new directory path name """ & New_Directory & '"';
385
 
386
      else
387
         --  Build New_Dir with a directory separator at the end, so that the
388
         --  complete path will be found in the loop below.
389
 
390
         New_Dir (1 .. New_Directory'Length) := New_Directory;
391
         New_Dir (New_Dir'Last) := Directory_Separator;
392
 
393
         --  Create, if necessary, each directory in the path
394
 
395
         for J in 2 .. New_Dir'Last loop
396
 
397
            --  Look for the end of an intermediate directory
398
 
399
            if New_Dir (J) /= Dir_Separator and then
400
               New_Dir (J) /= '/'
401
            then
402
               Last := J;
403
 
404
            --  We have found a new intermediate directory each time we find
405
            --  a first directory separator.
406
 
407
            elsif New_Dir (J - 1) /= Dir_Separator and then
408
                  New_Dir (J - 1) /= '/'
409
            then
410
 
411
               --  No need to create the directory if it already exists
412
 
413
               if Is_Directory (New_Dir (1 .. Last)) then
414
                  null;
415
 
416
               --  It is an error if a file with such a name already exists
417
 
418
               elsif Is_Regular_File (New_Dir (1 .. Last)) then
419
                  raise Use_Error with
420
                    "file """ & New_Dir (1 .. Last) & """ already exists";
421
 
422
               else
423
                  Create_Directory (New_Directory => New_Dir (1 .. Last));
424
               end if;
425
            end if;
426
         end loop;
427
      end if;
428
   end Create_Path;
429
 
430
   -----------------------
431
   -- Current_Directory --
432
   -----------------------
433
 
434
   function Current_Directory return String is
435
      Path_Len : Natural := Max_Path;
436
      Buffer   : String (1 .. 1 + Max_Path + 1);
437
 
438
      procedure Local_Get_Current_Dir
439
        (Dir    : System.Address;
440
         Length : System.Address);
441
      pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
442
 
443
   begin
444
      Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
445
 
446
      declare
447
         --  We need to resolve links because of A.16(47), since we must not
448
         --  return alternative names for files
449
         Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));
450
 
451
      begin
452
         if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
453
            return Cur (1 .. Cur'Last - 1);
454
         else
455
            return Cur;
456
         end if;
457
      end;
458
   end Current_Directory;
459
 
460
   ----------------------
461
   -- Delete_Directory --
462
   ----------------------
463
 
464
   procedure Delete_Directory (Directory : String) is
465
   begin
466
      --  First, the invalid cases
467
 
468
      if not Is_Valid_Path_Name (Directory) then
469
         raise Name_Error with
470
           "invalid directory path name """ & Directory & '"';
471
 
472
      elsif not Is_Directory (Directory) then
473
         raise Name_Error with '"' & Directory & """ not a directory";
474
 
475
      else
476
         declare
477
            C_Dir_Name : constant String := Directory & ASCII.NUL;
478
 
479
         begin
480
            if rmdir (C_Dir_Name) /= 0 then
481
               raise Use_Error with
482
                 "deletion of directory """ & Directory & """ failed";
483
            end if;
484
         end;
485
      end if;
486
   end Delete_Directory;
487
 
488
   -----------------
489
   -- Delete_File --
490
   -----------------
491
 
492
   procedure Delete_File (Name : String) is
493
      Success : Boolean;
494
 
495
   begin
496
      --  First, the invalid cases
497
 
498
      if not Is_Valid_Path_Name (Name) then
499
         raise Name_Error with "invalid path name """ & Name & '"';
500
 
501
      elsif not Is_Regular_File (Name) then
502
         raise Name_Error with "file """ & Name & """ does not exist";
503
 
504
      else
505
         --  The implementation uses System.OS_Lib.Delete_File
506
 
507
         Delete_File (Name, Success);
508
 
509
         if not Success then
510
            raise Use_Error with "file """ & Name & """ could not be deleted";
511
         end if;
512
      end if;
513
   end Delete_File;
514
 
515
   -----------------
516
   -- Delete_Tree --
517
   -----------------
518
 
519
   procedure Delete_Tree (Directory : String) is
520
      Current_Dir : constant String := Current_Directory;
521
      Search      : Search_Type;
522
      Dir_Ent     : Directory_Entry_Type;
523
   begin
524
      --  First, the invalid cases
525
 
526
      if not Is_Valid_Path_Name (Directory) then
527
         raise Name_Error with
528
           "invalid directory path name """ & Directory & '"';
529
 
530
      elsif not Is_Directory (Directory) then
531
         raise Name_Error with '"' & Directory & """ not a directory";
532
 
533
      else
534
         Set_Directory (Directory);
535
         Start_Search (Search, Directory => ".", Pattern => "");
536
 
537
         while More_Entries (Search) loop
538
            Get_Next_Entry (Search, Dir_Ent);
539
 
540
            declare
541
               File_Name : constant String := Simple_Name (Dir_Ent);
542
 
543
            begin
544
               if System.OS_Lib.Is_Directory (File_Name) then
545
                  if File_Name /= "." and then File_Name /= ".." then
546
                     Delete_Tree (File_Name);
547
                  end if;
548
 
549
               else
550
                  Delete_File (File_Name);
551
               end if;
552
            end;
553
         end loop;
554
 
555
         Set_Directory (Current_Dir);
556
         End_Search (Search);
557
 
558
         declare
559
            C_Dir_Name : constant String := Directory & ASCII.NUL;
560
 
561
         begin
562
            if rmdir (C_Dir_Name) /= 0 then
563
               raise Use_Error with
564
                 "directory tree rooted at """ &
565
                   Directory & """ could not be deleted";
566
            end if;
567
         end;
568
      end if;
569
   end Delete_Tree;
570
 
571
   ------------
572
   -- Exists --
573
   ------------
574
 
575
   function Exists (Name : String) return Boolean is
576
   begin
577
      --  First, the invalid case
578
 
579
      if not Is_Valid_Path_Name (Name) then
580
         raise Name_Error with "invalid path name """ & Name & '"';
581
 
582
      else
583
         --  The implementation is in File_Exists
584
 
585
         return File_Exists (Name);
586
      end if;
587
   end Exists;
588
 
589
   ---------------
590
   -- Extension --
591
   ---------------
592
 
593
   function Extension (Name : String) return String is
594
   begin
595
      --  First, the invalid case
596
 
597
      if not Is_Valid_Path_Name (Name) then
598
         raise Name_Error with "invalid path name """ & Name & '"';
599
 
600
      else
601
         --  Look for first dot that is not followed by a directory separator
602
 
603
         for Pos in reverse Name'Range loop
604
 
605
            --  If a directory separator is found before a dot, there is no
606
            --  extension.
607
 
608
            if Name (Pos) = Dir_Separator then
609
               return Empty_String;
610
 
611
            elsif Name (Pos) = '.' then
612
 
613
               --  We found a dot, build the return value with lower bound 1
614
 
615
               declare
616
                  subtype Result_Type is String (1 .. Name'Last - Pos);
617
               begin
618
                  return Result_Type (Name (Pos + 1 .. Name'Last));
619
               end;
620
            end if;
621
         end loop;
622
 
623
         --  No dot were found, there is no extension
624
 
625
         return Empty_String;
626
      end if;
627
   end Extension;
628
 
629
   ----------------------
630
   -- Fetch_Next_Entry --
631
   ----------------------
632
 
633
   procedure Fetch_Next_Entry (Search : Search_Type) is
634
      Name : String (1 .. 255);
635
      Last : Natural;
636
 
637
      Kind : File_Kind := Ordinary_File;
638
      --  Initialized to avoid a compilation warning
639
 
640
      Filename_Addr : System.Address;
641
      Filename_Len  : aliased Integer;
642
 
643
      Buffer : array (0 .. Filename_Max + 12) of Character;
644
      --  12 is the size of the dirent structure (see dirent.h), without the
645
      --  field for the filename.
646
 
647
      function readdir_gnat
648
        (Directory : System.Address;
649
         Buffer    : System.Address;
650
         Last      : not null access Integer) return System.Address;
651
      pragma Import (C, readdir_gnat, "__gnat_readdir");
652
 
653
      use System;
654
 
655
   begin
656
      --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
657
 
658
      loop
659
         Filename_Addr :=
660
           readdir_gnat
661
             (System.Address (Search.Value.Dir),
662
              Buffer'Address,
663
              Filename_Len'Access);
664
 
665
         --  If no matching entry is found, set Is_Valid to False
666
 
667
         if Filename_Addr = System.Null_Address then
668
            Search.Value.Is_Valid := False;
669
            exit;
670
         end if;
671
 
672
         declare
673
            subtype Path_String is String (1 .. Filename_Len);
674
            type    Path_String_Access is access Path_String;
675
 
676
            function Address_To_Access is new
677
              Ada.Unchecked_Conversion
678
                (Source => Address,
679
                 Target => Path_String_Access);
680
 
681
            Path_Access : constant Path_String_Access :=
682
                            Address_To_Access (Filename_Addr);
683
 
684
         begin
685
            Last := Filename_Len;
686
            Name (1 .. Last) := Path_Access.all;
687
         end;
688
 
689
         --  Check if the entry matches the pattern
690
 
691
         if Match (Name (1 .. Last), Search.Value.Pattern) then
692
            declare
693
               Full_Name : constant String :=
694
                             Compose
695
                               (To_String
696
                                  (Search.Value.Name), Name (1 .. Last));
697
               Found     : Boolean := False;
698
 
699
            begin
700
               if File_Exists (Full_Name) then
701
 
702
                  --  Now check if the file kind matches the filter
703
 
704
                  if Is_Regular_File (Full_Name) then
705
                     if Search.Value.Filter (Ordinary_File) then
706
                        Kind := Ordinary_File;
707
                        Found := True;
708
                     end if;
709
 
710
                  elsif Is_Directory (Full_Name) then
711
                     if Search.Value.Filter (Directory) then
712
                        Kind := Directory;
713
                        Found := True;
714
                     end if;
715
 
716
                  elsif Search.Value.Filter (Special_File) then
717
                     Kind := Special_File;
718
                     Found := True;
719
                  end if;
720
 
721
                  --  If it does, update Search and return
722
 
723
                  if Found then
724
                     Search.Value.Entry_Fetched := True;
725
                     Search.Value.Dir_Entry :=
726
                       (Is_Valid => True,
727
                        Simple   => To_Unbounded_String (Name (1 .. Last)),
728
                        Full     => To_Unbounded_String (Full_Name),
729
                        Kind     => Kind);
730
                     exit;
731
                  end if;
732
               end if;
733
            end;
734
         end if;
735
      end loop;
736
   end Fetch_Next_Entry;
737
 
738
   -----------------
739
   -- File_Exists --
740
   -----------------
741
 
742
   function File_Exists (Name : String) return Boolean is
743
      function C_File_Exists (A : System.Address) return Integer;
744
      pragma Import (C, C_File_Exists, "__gnat_file_exists");
745
 
746
      C_Name : String (1 .. Name'Length + 1);
747
 
748
   begin
749
      C_Name (1 .. Name'Length) := Name;
750
      C_Name (C_Name'Last) := ASCII.NUL;
751
      return C_File_Exists (C_Name (1)'Address) = 1;
752
   end File_Exists;
753
 
754
   --------------
755
   -- Finalize --
756
   --------------
757
 
758
   procedure Finalize (Search : in out Search_Type) is
759
   begin
760
      if Search.Value /= null then
761
 
762
         --  Close the directory, if one is open
763
 
764
         if Search.Value.Dir /= No_Dir then
765
            Close (Search.Value.Dir);
766
         end if;
767
 
768
         Free (Search.Value);
769
      end if;
770
   end Finalize;
771
 
772
   ---------------
773
   -- Full_Name --
774
   ---------------
775
 
776
   function Full_Name (Name : String) return String is
777
   begin
778
      --  First, the invalid case
779
 
780
      if not Is_Valid_Path_Name (Name) then
781
         raise Name_Error with "invalid path name """ & Name & '"';
782
 
783
      else
784
         --  Build the return value with lower bound 1
785
 
786
         --  Use System.OS_Lib.Normalize_Pathname
787
 
788
         declare
789
            --  We need to resolve links because of A.16(47), since we must not
790
            --  return alternative names for files
791
            Value : constant String := Normalize_Pathname (Name);
792
            subtype Result is String (1 .. Value'Length);
793
         begin
794
            return Result (Value);
795
         end;
796
      end if;
797
   end Full_Name;
798
 
799
   function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
800
   begin
801
      --  First, the invalid case
802
 
803
      if not Directory_Entry.Is_Valid then
804
         raise Status_Error with "invalid directory entry";
805
 
806
      else
807
         --  The value to return has already been computed
808
 
809
         return To_String (Directory_Entry.Full);
810
      end if;
811
   end Full_Name;
812
 
813
   --------------------
814
   -- Get_Next_Entry --
815
   --------------------
816
 
817
   procedure Get_Next_Entry
818
     (Search          : in out Search_Type;
819
      Directory_Entry : out Directory_Entry_Type)
820
   is
821
   begin
822
      --  First, the invalid case
823
 
824
      if Search.Value = null or else not Search.Value.Is_Valid then
825
         raise Status_Error with "invalid search";
826
      end if;
827
 
828
      --  Fetch the next entry, if needed
829
 
830
      if not Search.Value.Entry_Fetched then
831
         Fetch_Next_Entry (Search);
832
      end if;
833
 
834
      --  It is an error if no valid entry is found
835
 
836
      if not Search.Value.Is_Valid then
837
         raise Status_Error with "no next entry";
838
 
839
      else
840
         --  Reset Entry_Fetched and return the entry
841
 
842
         Search.Value.Entry_Fetched := False;
843
         Directory_Entry := Search.Value.Dir_Entry;
844
      end if;
845
   end Get_Next_Entry;
846
 
847
   ----------
848
   -- Kind --
849
   ----------
850
 
851
   function Kind (Name : String) return File_Kind is
852
   begin
853
      --  First, the invalid case
854
 
855
      if not File_Exists (Name) then
856
         raise Name_Error with "file """ & Name & """ does not exist";
857
 
858
      elsif Is_Regular_File (Name) then
859
         return Ordinary_File;
860
 
861
      elsif Is_Directory (Name) then
862
         return Directory;
863
 
864
      else
865
         return Special_File;
866
      end if;
867
   end Kind;
868
 
869
   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
870
   begin
871
      --  First, the invalid case
872
 
873
      if not Directory_Entry.Is_Valid then
874
         raise Status_Error with "invalid directory entry";
875
 
876
      else
877
         --  The value to return has already be computed
878
 
879
         return Directory_Entry.Kind;
880
      end if;
881
   end Kind;
882
 
883
   -----------------------
884
   -- Modification_Time --
885
   -----------------------
886
 
887
   function Modification_Time (Name : String) return Time is
888
      Date   : OS_Time;
889
      Year   : Year_Type;
890
      Month  : Month_Type;
891
      Day    : Day_Type;
892
      Hour   : Hour_Type;
893
      Minute : Minute_Type;
894
      Second : Second_Type;
895
      Result : Time;
896
 
897
   begin
898
      --  First, the invalid cases
899
 
900
      if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
901
         raise Name_Error with '"' & Name & """ not a file or directory";
902
 
903
      else
904
         Date := File_Time_Stamp (Name);
905
 
906
         --  Break down the time stamp into its constituents relative to GMT.
907
         --  This version of Split does not recognize leap seconds or buffer
908
         --  space for time zone processing.
909
 
910
         GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
911
 
912
         --  On OpenVMS, the resulting time value must be in the local time
913
         --  zone. Ada.Calendar.Time_Of is exactly what we need. Note that
914
         --  in both cases, the sub seconds are set to zero (0.0) because the
915
         --  time stamp does not store them in its value.
916
 
917
         if OpenVMS then
918
            Result :=
919
              Ada.Calendar.Time_Of
920
                (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0));
921
 
922
         --  On Unix and Windows, the result must be in GMT. Ada.Calendar.
923
         --  Formatting.Time_Of with default time zone of zero (0) is the
924
         --  routine of choice.
925
 
926
         else
927
            Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
928
         end if;
929
 
930
         return Result;
931
      end if;
932
   end Modification_Time;
933
 
934
   function Modification_Time
935
     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
936
   is
937
   begin
938
      --  First, the invalid case
939
 
940
      if not Directory_Entry.Is_Valid then
941
         raise Status_Error with "invalid directory entry";
942
 
943
      else
944
         --  The value to return has already be computed
945
 
946
         return Modification_Time (To_String (Directory_Entry.Full));
947
      end if;
948
   end Modification_Time;
949
 
950
   ------------------
951
   -- More_Entries --
952
   ------------------
953
 
954
   function More_Entries (Search : Search_Type) return Boolean is
955
   begin
956
      if Search.Value = null then
957
         return False;
958
 
959
      elsif Search.Value.Is_Valid then
960
 
961
         --  Fetch the next entry, if needed
962
 
963
         if not Search.Value.Entry_Fetched then
964
            Fetch_Next_Entry (Search);
965
         end if;
966
      end if;
967
 
968
      return Search.Value.Is_Valid;
969
   end More_Entries;
970
 
971
   ------------
972
   -- Rename --
973
   ------------
974
 
975
   procedure Rename (Old_Name, New_Name : String) is
976
      Success : Boolean;
977
 
978
   begin
979
      --  First, the invalid cases
980
 
981
      if not Is_Valid_Path_Name (Old_Name) then
982
         raise Name_Error with "invalid old path name """ & Old_Name & '"';
983
 
984
      elsif not Is_Valid_Path_Name (New_Name) then
985
         raise Name_Error with "invalid new path name """ & New_Name & '"';
986
 
987
      elsif not Is_Regular_File (Old_Name)
988
            and then not Is_Directory (Old_Name)
989
      then
990
         raise Name_Error with "old file """ & Old_Name & """ does not exist";
991
 
992
      elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
993
         raise Use_Error with
994
           "new name """ & New_Name
995
           & """ designates a file that already exists";
996
 
997
      else
998
         --  The implementation uses System.OS_Lib.Rename_File
999
 
1000
         Rename_File (Old_Name, New_Name, Success);
1001
 
1002
         if not Success then
1003
            raise Use_Error with
1004
              "file """ & Old_Name & """ could not be renamed";
1005
         end if;
1006
      end if;
1007
   end Rename;
1008
 
1009
   ------------
1010
   -- Search --
1011
   ------------
1012
 
1013
   procedure Search
1014
     (Directory : String;
1015
      Pattern   : String;
1016
      Filter    : Filter_Type := (others => True);
1017
      Process   : not null access procedure
1018
                                    (Directory_Entry : Directory_Entry_Type))
1019
   is
1020
      Srch            : Search_Type;
1021
      Directory_Entry : Directory_Entry_Type;
1022
 
1023
   begin
1024
      Start_Search (Srch, Directory, Pattern, Filter);
1025
 
1026
      while More_Entries (Srch) loop
1027
         Get_Next_Entry (Srch, Directory_Entry);
1028
         Process (Directory_Entry);
1029
      end loop;
1030
 
1031
      End_Search (Srch);
1032
   end Search;
1033
 
1034
   -------------------
1035
   -- Set_Directory --
1036
   -------------------
1037
 
1038
   procedure Set_Directory (Directory : String) is
1039
      C_Dir_Name : constant String := Directory & ASCII.NUL;
1040
   begin
1041
      if not Is_Valid_Path_Name (Directory) then
1042
         raise Name_Error with
1043
           "invalid directory path name & """ & Directory & '"';
1044
 
1045
      elsif not Is_Directory (Directory) then
1046
         raise Name_Error with
1047
           "directory """ & Directory & """ does not exist";
1048
 
1049
      elsif chdir (C_Dir_Name) /= 0 then
1050
         raise Name_Error with
1051
           "could not set to designated directory """ & Directory & '"';
1052
      end if;
1053
   end Set_Directory;
1054
 
1055
   -----------------
1056
   -- Simple_Name --
1057
   -----------------
1058
 
1059
   function Simple_Name (Name : String) return String is
1060
 
1061
      function Simple_Name_Internal (Path : String) return String;
1062
      --  This function does the job
1063
 
1064
      --------------------------
1065
      -- Simple_Name_Internal --
1066
      --------------------------
1067
 
1068
      function Simple_Name_Internal (Path : String) return String is
1069
         Cut_Start : Natural :=
1070
                       Strings.Fixed.Index
1071
                         (Path, Dir_Seps, Going => Strings.Backward);
1072
         Cut_End   : Natural;
1073
 
1074
      begin
1075
         --  Cut_Start pointS to the first simple name character
1076
 
1077
         Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1078
 
1079
         --  Cut_End point to the last simple name character
1080
 
1081
         Cut_End := Path'Last;
1082
 
1083
         Check_For_Standard_Dirs : declare
1084
            BN               : constant String := Path (Cut_Start .. Cut_End);
1085
            Has_Drive_Letter : constant Boolean :=
1086
                                 System.OS_Lib.Path_Separator /= ':';
1087
            --  If Path separator is not ':' then we are on a DOS based OS
1088
            --  where this character is used as a drive letter separator.
1089
 
1090
         begin
1091
            if BN = "." or else BN = ".." then
1092
               return "";
1093
 
1094
            elsif Has_Drive_Letter
1095
              and then BN'Length > 2
1096
              and then Characters.Handling.Is_Letter (BN (BN'First))
1097
              and then BN (BN'First + 1) = ':'
1098
            then
1099
               --  We have a DOS drive letter prefix, remove it
1100
 
1101
               return BN (BN'First + 2 .. BN'Last);
1102
 
1103
            else
1104
               return BN;
1105
            end if;
1106
         end Check_For_Standard_Dirs;
1107
      end Simple_Name_Internal;
1108
 
1109
   --  Start of processing for Simple_Name
1110
 
1111
   begin
1112
      --  First, the invalid case
1113
 
1114
      if not Is_Valid_Path_Name (Name) then
1115
         raise Name_Error with "invalid path name """ & Name & '"';
1116
 
1117
      else
1118
         --  Build the value to return with lower bound 1
1119
 
1120
         declare
1121
            Value : constant String := Simple_Name_Internal (Name);
1122
            subtype Result is String (1 .. Value'Length);
1123
         begin
1124
            return Result (Value);
1125
         end;
1126
      end if;
1127
   end Simple_Name;
1128
 
1129
   function Simple_Name
1130
     (Directory_Entry : Directory_Entry_Type) return String is
1131
   begin
1132
      --  First, the invalid case
1133
 
1134
      if not Directory_Entry.Is_Valid then
1135
         raise Status_Error with "invalid directory entry";
1136
 
1137
      else
1138
         --  The value to return has already be computed
1139
 
1140
         return To_String (Directory_Entry.Simple);
1141
      end if;
1142
   end Simple_Name;
1143
 
1144
   ----------
1145
   -- Size --
1146
   ----------
1147
 
1148
   function Size (Name : String) return File_Size is
1149
      C_Name : String (1 .. Name'Length + 1);
1150
 
1151
      function C_Size (Name : System.Address) return Long_Integer;
1152
      pragma Import (C, C_Size, "__gnat_named_file_length");
1153
 
1154
   begin
1155
      --  First, the invalid case
1156
 
1157
      if not Is_Regular_File (Name) then
1158
         raise Name_Error with "file """ & Name & """ does not exist";
1159
 
1160
      else
1161
         C_Name (1 .. Name'Length) := Name;
1162
         C_Name (C_Name'Last) := ASCII.NUL;
1163
         return File_Size (C_Size (C_Name'Address));
1164
      end if;
1165
   end Size;
1166
 
1167
   function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1168
   begin
1169
      --  First, the invalid case
1170
 
1171
      if not Directory_Entry.Is_Valid then
1172
         raise Status_Error with "invalid directory entry";
1173
 
1174
      else
1175
         --  The value to return has already be computed
1176
 
1177
         return Size (To_String (Directory_Entry.Full));
1178
      end if;
1179
   end Size;
1180
 
1181
   ------------------
1182
   -- Start_Search --
1183
   ------------------
1184
 
1185
   procedure Start_Search
1186
     (Search    : in out Search_Type;
1187
      Directory : String;
1188
      Pattern   : String;
1189
      Filter    : Filter_Type := (others => True))
1190
   is
1191
      function opendir (file_name : String) return DIRs;
1192
      pragma Import (C, opendir, "__gnat_opendir");
1193
 
1194
      C_File_Name : constant String := Directory & ASCII.NUL;
1195
      Pat         : Regexp;
1196
      Dir         : Dir_Type_Value;
1197
 
1198
   begin
1199
      --  First, the invalid case Name_Error
1200
 
1201
      if not Is_Directory (Directory) then
1202
         raise Name_Error with
1203
           "unknown directory """ & Simple_Name (Directory) & '"';
1204
      end if;
1205
 
1206
      --  Check the pattern
1207
 
1208
      begin
1209
         Pat := Compile
1210
           (Pattern,
1211
            Glob           => True,
1212
            Case_Sensitive => Is_Path_Name_Case_Sensitive);
1213
      exception
1214
         when Error_In_Regexp =>
1215
            Free (Search.Value);
1216
            raise Name_Error with "invalid pattern """ & Pattern & '"';
1217
      end;
1218
 
1219
      Dir := Dir_Type_Value (opendir (C_File_Name));
1220
 
1221
      if Dir = No_Dir then
1222
         raise Use_Error with
1223
           "unreadable directory """ & Simple_Name (Directory) & '"';
1224
      end if;
1225
 
1226
      --  If needed, finalize Search
1227
 
1228
      Finalize (Search);
1229
 
1230
      --  Allocate the default data
1231
 
1232
      Search.Value := new Search_Data;
1233
 
1234
      --  Initialize some Search components
1235
 
1236
      Search.Value.Filter   := Filter;
1237
      Search.Value.Name     := To_Unbounded_String (Full_Name (Directory));
1238
      Search.Value.Pattern  := Pat;
1239
      Search.Value.Dir      := Dir;
1240
      Search.Value.Is_Valid := True;
1241
   end Start_Search;
1242
 
1243
end Ada.Directories;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.