1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                A D A . S T R E A M S . S T R E A M _ I O                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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
32with Interfaces.C_Streams; use Interfaces.C_Streams;
33
34with System;               use System;
35with System.Communication; use System.Communication;
36with System.File_IO;
37with System.Soft_Links;
38with System.CRTL;
39
40with Ada.Unchecked_Conversion;
41with Ada.Unchecked_Deallocation;
42
43package body Ada.Streams.Stream_IO is
44
45   package FIO renames System.File_IO;
46   package SSL renames System.Soft_Links;
47
48   subtype AP is FCB.AFCB_Ptr;
49
50   function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
51   function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
52   use type FCB.File_Mode;
53   use type FCB.Shared_Status_Type;
54
55   -----------------------
56   -- Local Subprograms --
57   -----------------------
58
59   procedure Set_Position (File : File_Type);
60   --  Sets file position pointer according to value of current index
61
62   -------------------
63   -- AFCB_Allocate --
64   -------------------
65
66   function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is
67      pragma Warnings (Off, Control_Block);
68   begin
69      return new Stream_AFCB;
70   end AFCB_Allocate;
71
72   ----------------
73   -- AFCB_Close --
74   ----------------
75
76   --  No special processing required for closing Stream_IO file
77
78   procedure AFCB_Close (File : not null access Stream_AFCB) is
79      pragma Warnings (Off, File);
80   begin
81      null;
82   end AFCB_Close;
83
84   ---------------
85   -- AFCB_Free --
86   ---------------
87
88   procedure AFCB_Free (File : not null access Stream_AFCB) is
89      type FCB_Ptr is access all Stream_AFCB;
90      FT : FCB_Ptr := FCB_Ptr (File);
91
92      procedure Free is new Ada.Unchecked_Deallocation (Stream_AFCB, FCB_Ptr);
93
94   begin
95      Free (FT);
96   end AFCB_Free;
97
98   -----------
99   -- Close --
100   -----------
101
102   procedure Close (File : in out File_Type) is
103   begin
104      FIO.Close (AP (File)'Unrestricted_Access);
105   end Close;
106
107   ------------
108   -- Create --
109   ------------
110
111   procedure Create
112     (File : in out File_Type;
113      Mode : File_Mode := Out_File;
114      Name : String := "";
115      Form : String := "")
116   is
117      Dummy_File_Control_Block : Stream_AFCB;
118      pragma Warnings (Off, Dummy_File_Control_Block);
119      --  Yes, we know this is never assigned a value, only the tag
120      --  is used for dispatching purposes, so that's expected.
121
122   begin
123      FIO.Open (File_Ptr  => AP (File),
124                Dummy_FCB => Dummy_File_Control_Block,
125                Mode      => To_FCB (Mode),
126                Name      => Name,
127                Form      => Form,
128                Amethod   => 'S',
129                Creat     => True,
130                Text      => False);
131      File.Last_Op := Op_Write;
132   end Create;
133
134   ------------
135   -- Delete --
136   ------------
137
138   procedure Delete (File : in out File_Type) is
139   begin
140      FIO.Delete (AP (File)'Unrestricted_Access);
141   end Delete;
142
143   -----------------
144   -- End_Of_File --
145   -----------------
146
147   function End_Of_File (File : File_Type) return Boolean is
148   begin
149      FIO.Check_Read_Status (AP (File));
150      return File.Index > Size (File);
151   end End_Of_File;
152
153   -----------
154   -- Flush --
155   -----------
156
157   procedure Flush (File : File_Type) is
158   begin
159      FIO.Flush (AP (File));
160   end Flush;
161
162   ----------
163   -- Form --
164   ----------
165
166   function Form (File : File_Type) return String is
167   begin
168      return FIO.Form (AP (File));
169   end Form;
170
171   -----------
172   -- Index --
173   -----------
174
175   function Index (File : File_Type) return Positive_Count is
176   begin
177      FIO.Check_File_Open (AP (File));
178      return File.Index;
179   end Index;
180
181   -------------
182   -- Is_Open --
183   -------------
184
185   function Is_Open (File : File_Type) return Boolean is
186   begin
187      return FIO.Is_Open (AP (File));
188   end Is_Open;
189
190   ----------
191   -- Mode --
192   ----------
193
194   function Mode (File : File_Type) return File_Mode is
195   begin
196      return To_SIO (FIO.Mode (AP (File)));
197   end Mode;
198
199   ----------
200   -- Name --
201   ----------
202
203   function Name (File : File_Type) return String is
204   begin
205      return FIO.Name (AP (File));
206   end Name;
207
208   ----------
209   -- Open --
210   ----------
211
212   procedure Open
213     (File : in out File_Type;
214      Mode : File_Mode;
215      Name : String;
216      Form : String := "")
217   is
218      Dummy_File_Control_Block : Stream_AFCB;
219      pragma Warnings (Off, Dummy_File_Control_Block);
220      --  Yes, we know this is never assigned a value, only the tag
221      --  is used for dispatching purposes, so that's expected.
222
223   begin
224      FIO.Open (File_Ptr  => AP (File),
225                Dummy_FCB => Dummy_File_Control_Block,
226                Mode      => To_FCB (Mode),
227                Name      => Name,
228                Form      => Form,
229                Amethod   => 'S',
230                Creat     => False,
231                Text      => False);
232
233      --  Ensure that the stream index is set properly (e.g., for Append_File)
234
235      Reset (File, Mode);
236
237      --  Set last operation. The purpose here is to ensure proper handling
238      --  of the initial operation. In general, a write after a read requires
239      --  resetting and doing a seek, so we set the last operation as Read
240      --  for an In_Out file, but for an Out file we set the last operation
241      --  to Op_Write, since in this case it is not necessary to do a seek
242      --  (and furthermore there are situations (such as the case of writing
243      --  a sequential Posix FIFO file) where the lseek would cause problems.
244
245      File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read);
246   end Open;
247
248   ----------
249   -- Read --
250   ----------
251
252   procedure Read
253     (File : File_Type;
254      Item : out Stream_Element_Array;
255      Last : out Stream_Element_Offset;
256      From : Positive_Count)
257   is
258   begin
259      Set_Index (File, From);
260      Read (File, Item, Last);
261   end Read;
262
263   procedure Read
264     (File : File_Type;
265      Item : out Stream_Element_Array;
266      Last : out Stream_Element_Offset)
267   is
268      Nread : size_t;
269
270   begin
271      FIO.Check_Read_Status (AP (File));
272
273      --  If last operation was not a read, or if in file sharing mode,
274      --  then reset the physical pointer of the file to match the index
275      --  We lock out task access over the two operations in this case.
276
277      if File.Last_Op /= Op_Read
278        or else File.Shared_Status = FCB.Yes
279      then
280         Locked_Processing : begin
281            SSL.Lock_Task.all;
282            Set_Position (File);
283            FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
284            SSL.Unlock_Task.all;
285
286         exception
287            when others =>
288               SSL.Unlock_Task.all;
289               raise;
290         end Locked_Processing;
291
292      else
293         FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread);
294      end if;
295
296      File.Index := File.Index + Count (Nread);
297      File.Last_Op := Op_Read;
298      Last := Last_Index (Item'First, Nread);
299   end Read;
300
301   --  This version of Read is the primitive operation on the underlying
302   --  Stream type, used when a Stream_IO file is treated as a Stream
303
304   procedure Read
305     (File : in out Stream_AFCB;
306      Item : out Ada.Streams.Stream_Element_Array;
307      Last : out Ada.Streams.Stream_Element_Offset)
308   is
309   begin
310      Read (File'Unchecked_Access, Item, Last);
311   end Read;
312
313   -----------
314   -- Reset --
315   -----------
316
317   procedure Reset (File : in out File_Type; Mode : File_Mode) is
318   begin
319      FIO.Check_File_Open (AP (File));
320
321      --  Reset file index to start of file for read/write cases. For
322      --  the append case, the Set_Mode call repositions the index.
323
324      File.Index := 1;
325      Set_Mode (File, Mode);
326   end Reset;
327
328   procedure Reset (File : in out File_Type) is
329   begin
330      Reset (File, To_SIO (File.Mode));
331   end Reset;
332
333   ---------------
334   -- Set_Index --
335   ---------------
336
337   procedure Set_Index (File : File_Type; To : Positive_Count) is
338   begin
339      FIO.Check_File_Open (AP (File));
340      File.Index := Count (To);
341      File.Last_Op := Op_Other;
342   end Set_Index;
343
344   --------------
345   -- Set_Mode --
346   --------------
347
348   procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is
349   begin
350      FIO.Check_File_Open (AP (File));
351
352      --  If we are switching from read to write, or vice versa, and
353      --  we are not already open in update mode, then reopen in update
354      --  mode now. Note that we can use Inout_File as the mode for the
355      --  call since File_IO handles all modes for all file types.
356
357      if ((File.Mode = FCB.In_File) /= (Mode = In_File))
358        and then not File.Update_Mode
359      then
360         FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File);
361         File.Update_Mode := True;
362      end if;
363
364      --  Set required mode and position to end of file if append mode
365
366      File.Mode := To_FCB (Mode);
367      FIO.Append_Set (AP (File));
368
369      if File.Mode = FCB.Append_File then
370         if Standard'Address_Size = 64 then
371            File.Index := Count (ftell64 (File.Stream)) + 1;
372         else
373            File.Index := Count (ftell (File.Stream)) + 1;
374         end if;
375      end if;
376
377      File.Last_Op := Op_Other;
378   end Set_Mode;
379
380   ------------------
381   -- Set_Position --
382   ------------------
383
384   procedure Set_Position (File : File_Type) is
385      use type System.CRTL.int64;
386      R : int;
387   begin
388      R := fseek64 (File.Stream, System.CRTL.int64 (File.Index) - 1, SEEK_SET);
389
390      if R /= 0 then
391         raise Use_Error;
392      end if;
393   end Set_Position;
394
395   ----------
396   -- Size --
397   ----------
398
399   function Size (File : File_Type) return Count is
400   begin
401      FIO.Check_File_Open (AP (File));
402
403      if File.File_Size = -1 then
404         File.Last_Op := Op_Other;
405
406         if fseek64 (File.Stream, 0, SEEK_END) /= 0 then
407            raise Device_Error;
408         end if;
409
410         File.File_Size := Stream_Element_Offset (ftell64 (File.Stream));
411
412         if File.File_Size = -1 then
413            raise Use_Error;
414         end if;
415      end if;
416
417      return Count (File.File_Size);
418   end Size;
419
420   ------------
421   -- Stream --
422   ------------
423
424   function Stream (File : File_Type) return Stream_Access is
425   begin
426      FIO.Check_File_Open (AP (File));
427      return Stream_Access (File);
428   end Stream;
429
430   -----------
431   -- Write --
432   -----------
433
434   procedure Write
435     (File : File_Type;
436      Item : Stream_Element_Array;
437      To   : Positive_Count)
438   is
439   begin
440      Set_Index (File, To);
441      Write (File, Item);
442   end Write;
443
444   procedure Write
445     (File : File_Type;
446      Item : Stream_Element_Array)
447   is
448   begin
449      FIO.Check_Write_Status (AP (File));
450
451      --  If last operation was not a write, or if in file sharing mode,
452      --  then reset the physical pointer of the file to match the index
453      --  We lock out task access over the two operations in this case.
454
455      if File.Last_Op /= Op_Write
456        or else File.Shared_Status = FCB.Yes
457      then
458         Locked_Processing : begin
459            SSL.Lock_Task.all;
460            Set_Position (File);
461            FIO.Write_Buf (AP (File), Item'Address, Item'Length);
462            SSL.Unlock_Task.all;
463
464         exception
465            when others =>
466               SSL.Unlock_Task.all;
467               raise;
468         end Locked_Processing;
469
470      else
471         FIO.Write_Buf (AP (File), Item'Address, Item'Length);
472      end if;
473
474      File.Index := File.Index + Item'Length;
475      File.Last_Op := Op_Write;
476      File.File_Size := -1;
477   end Write;
478
479   --  This version of Write is the primitive operation on the underlying
480   --  Stream type, used when a Stream_IO file is treated as a Stream
481
482   procedure Write
483     (File : in out Stream_AFCB;
484      Item : Ada.Streams.Stream_Element_Array)
485   is
486   begin
487      Write (File'Unchecked_Access, Item);
488   end Write;
489
490end Ada.Streams.Stream_IO;
491