Source file : zip_streams.adb
1 -- Legal licensing note:
2
3 -- Copyright (c) 2008 .. 2023 Gautier de Montmollin (maintainer)
4 -- SWITZERLAND
5
6 -- Permission is hereby granted, free of charge, to any person obtaining a copy
7 -- of this software and associated documentation files (the "Software"), to deal
8 -- in the Software without restriction, including without limitation the rights
9 -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 -- copies of the Software, and to permit persons to whom the Software is
11 -- furnished to do so, subject to the following conditions:
12
13 -- The above copyright notice and this permission notice shall be included in
14 -- all copies or substantial portions of the Software.
15
16 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22 -- THE SOFTWARE.
23
24 -- NB: this is the MIT License, as found 21-Aug-2016 on the site
25 -- http://www.opensource.org/licenses/mit-license.php
26
27 ----------------
28 -- Some changes
29 --
30 -- 11-Nov-2009 (GdM): Unbounded_Stream.Write and .Set_Index are buffered
31 -- 18-Jan-2009 (GdM): Fixed Read(Stream, Item...) which read
32 -- only 1st element of Item
33
34 package body Zip_Streams is
35
36 use Ada.Strings.Unbounded;
37
38 procedure Set_Name (S : in out Root_Zipstream_Type; Name : String) is
39 begin
40 S.Name := To_Unbounded_String (Name);
41 end Set_Name;
42
43 function Get_Name (S : in Root_Zipstream_Type) return String is
44 begin
45 return To_String (S.Name);
46 end Get_Name;
47
48 procedure Set_Time (S : in out Root_Zipstream_Type; Modification_Time : Time) is
49 begin
50 S.Modification_Time := Modification_Time;
51 end Set_Time;
52
53 function Get_Time (S : in Root_Zipstream_Type) return Time is
54 begin
55 return S.Modification_Time;
56 end Get_Time;
57
58 -- Ada.Calendar versions
59
60 procedure Set_Time (S : in out Root_Zipstream_Type'Class;
61 Modification_Time : Ada.Calendar.Time) is
62 begin
63 Set_Time (S, Calendar.Convert (Modification_Time));
64 end Set_Time;
65
66 function Get_Time (S : in Root_Zipstream_Type'Class)
67 return Ada.Calendar.Time is
68 begin
69 return Calendar.Convert (Get_Time (S));
70 end Get_Time;
71
72 procedure Set_Unicode_Name_Flag (S : out Root_Zipstream_Type;
73 Value : in Boolean)
74 is
75 begin
76 S.Is_Unicode_Name := Value;
77 end Set_Unicode_Name_Flag;
78
79 function Is_Unicode_Name (S : in Root_Zipstream_Type)
80 return Boolean
81 is
82 begin
83 return S.Is_Unicode_Name;
84 end Is_Unicode_Name;
85
86 procedure Set_Read_Only_Flag (S : out Root_Zipstream_Type;
87 Value : in Boolean)
88 is
89 begin
90 S.Is_Read_Only := Value;
91 end Set_Read_Only_Flag;
92
93 function Is_Read_Only (S : in Root_Zipstream_Type)
94 return Boolean
95 is
96 begin
97 return S.Is_Read_Only;
98 end Is_Read_Only;
99
100 ---------------------------------------------------------------------
101 -- Unbounded_Stream: stream based on an in-memory Unbounded_String --
102 ---------------------------------------------------------------------
103 procedure Get (Str : Memory_Zipstream; Unb : out Ada.Strings.Unbounded.Unbounded_String) is
104 begin
105 Unb := Str.Unb;
106 end Get;
107
108 procedure Set (Str : in out Memory_Zipstream; Unb : Ada.Strings.Unbounded.Unbounded_String) is
109 begin
110 Str.Unb := Null_Unbounded_String; -- clear the content of the stream
111 Str.Unb := Unb;
112 Str.Loc := 1;
113 end Set;
114
115 use Ada.Streams;
116
117 overriding procedure Read
118 (Stream : in out Memory_Zipstream;
119 Item : out Ada.Streams.Stream_Element_Array;
120 Last : out Ada.Streams.Stream_Element_Offset)
121 is
122 begin
123 -- Item is read from the stream. If (and only if) the stream is
124 -- exhausted, Last will be < Item'Last. In that case, T'Read will
125 -- raise an End_Error exception.
126 --
127 -- Cf: RM 13.13.1(8), RM 13.13.1(11), RM 13.13.2(37) and
128 -- explanations by Tucker Taft
129 --
130 Last := Item'First - 1;
131 -- if Item is empty, the following loop is skipped; if Stream.Loc
132 -- is already indexing out of Stream.Unb, that value is also appropriate
133 for i in Item'Range loop
134 Item (i) := Character'Pos (Element (Stream.Unb, Stream.Loc));
135 Stream.Loc := Stream.Loc + 1;
136 Last := i;
137 end loop;
138 exception
139 when Ada.Strings.Index_Error =>
140 null; -- what could be read has been read; T'Read will raise End_Error
141 end Read;
142
143 max_chunk_size : constant := 16 * 1024;
144
145 overriding procedure Write
146 (Stream : in out Memory_Zipstream;
147 Item : Ada.Streams.Stream_Element_Array)
148 is
149 I : Stream_Element_Offset := Item'First;
150 chunk_size : Integer;
151 tmp : String (1 .. max_chunk_size);
152 begin
153 while I <= Item'Last loop
154 chunk_size := Integer'Min (Integer (Item'Last - I + 1), max_chunk_size);
155 if Stream.Loc > Length (Stream.Unb) then
156 -- ...we are off the string's bounds, we need to extend it.
157 for J in 1 .. chunk_size loop
158 tmp (J) := Character'Val (Item (I));
159 I := I + 1;
160 end loop;
161 Append (Stream.Unb, tmp (1 .. chunk_size));
162 else
163 -- ...we can work (at least for a part) within the string's bounds.
164 chunk_size := Integer'Min (chunk_size, Length (Stream.Unb) - Stream.Loc + 1);
165 for J in 0 .. chunk_size - 1 loop
166 Replace_Element (Stream.Unb, Stream.Loc + J, Character'Val (Item (I)));
167 -- GNAT 2008's Replace_Slice does something very general
168 -- even in the trivial case where one can make:
169 -- Source.Reference(Low..High):= By;
170 -- -> still faster with elem by elem replacement
171 -- Anyway, this place is not critical for zipping: only the
172 -- local header before compressed data is rewritten after
173 -- compression. So usually, we are off bounds.
174 I := I + 1;
175 end loop;
176 end if;
177 Stream.Loc := Stream.Loc + chunk_size;
178 end loop;
179 end Write;
180
181 overriding procedure Set_Index (S : in out Memory_Zipstream; To : ZS_Index_Type) is
182 I, chunk_size : ZS_Size_Type;
183 begin
184 if To > ZS_Size_Type (Length (S.Unb)) then
185 -- ...we are off the string's bounds, we need to extend it.
186 I := ZS_Size_Type (Length (S.Unb)) + 1;
187 while I <= To loop
188 chunk_size := ZS_Size_Type'Min (To - I + 1, ZS_Size_Type (max_chunk_size));
189 Append (S.Unb, (1 .. Integer (chunk_size) => ASCII.NUL));
190 I := I + chunk_size;
191 end loop;
192 end if;
193 S.Loc := Integer (To);
194 end Set_Index;
195
196 overriding function Size (S : in Memory_Zipstream) return ZS_Size_Type is
197 begin
198 return ZS_Size_Type (Length (S.Unb));
199 end Size;
200
201 overriding function Index (S : in Memory_Zipstream) return ZS_Index_Type is
202 begin
203 return ZS_Index_Type (S.Loc);
204 end Index;
205
206 overriding function End_Of_Stream (S : in Memory_Zipstream) return Boolean is
207 begin
208 if Size (S) < Index (S) then
209 return True;
210 else
211 return False;
212 end if;
213 end End_Of_Stream;
214
215 --------------------------------------------
216 -- File_Zipstream: stream based on a file --
217 --------------------------------------------
218 procedure Open (Str : in out File_Zipstream; Mode : File_Mode) is
219 begin
220 Ada.Streams.Stream_IO.Open (
221 Str.File,
222 Ada.Streams.Stream_IO.File_Mode (Mode),
223 To_String (Str.Name),
224 Form => To_String (Form_For_IO_Open_and_Create)
225 );
226 -- NB: we could have here a call to Set_Time using
227 -- Ada.Directories.Modification_Time if the latter
228 -- was able to accept the Form as above for Open
229 -- (this is needed for Unicode names).
230 end Open;
231
232 procedure Create (Str : in out File_Zipstream; Mode : File_Mode) is
233 begin
234 Ada.Streams.Stream_IO.Create (
235 Str.File,
236 Ada.Streams.Stream_IO.File_Mode (Mode),
237 To_String (Str.Name),
238 Form => To_String (Form_For_IO_Open_and_Create)
239 );
240 -- NB: we could have here a call to Set_Time using
241 -- Ada.Directories.Modification_Time if the latter
242 -- was able to accept the Form as above for Create
243 -- (this is needed for Unicode names).
244 end Create;
245
246 procedure Close (Str : in out File_Zipstream) is
247 begin
248 Ada.Streams.Stream_IO.Close (Str.File);
249 end Close;
250
251 function Is_Open (Str : in File_Zipstream) return Boolean is
252 begin
253 return Ada.Streams.Stream_IO.Is_Open (Str.File);
254 end Is_Open;
255
256 overriding procedure Read
257 (Stream : in out File_Zipstream;
258 Item : out Stream_Element_Array;
259 Last : out Stream_Element_Offset)
260 is
261 begin
262 Ada.Streams.Stream_IO.Read (Stream.File, Item, Last);
263 end Read;
264
265 overriding procedure Write
266 (Stream : in out File_Zipstream;
267 Item : Stream_Element_Array) is
268 begin
269 Ada.Streams.Stream_IO.Write (Stream.File, Item);
270 end Write;
271
272 overriding procedure Set_Index (S : in out File_Zipstream; To : ZS_Index_Type) is
273 begin
274 Ada.Streams.Stream_IO.Set_Index (
275 S.File,
276 Ada.Streams.Stream_IO.Positive_Count (To)
277 );
278 end Set_Index;
279
280 overriding function Size (S : in File_Zipstream) return ZS_Size_Type is
281 begin
282 return ZS_Size_Type (Ada.Streams.Stream_IO.Size (S.File));
283 end Size;
284
285 overriding function Index (S : in File_Zipstream) return ZS_Index_Type is
286 begin
287 return ZS_Index_Type (Ada.Streams.Stream_IO.Index (S.File));
288 end Index;
289
290 overriding function End_Of_Stream (S : in File_Zipstream) return Boolean is
291 begin
292 return Ada.Streams.Stream_IO.End_Of_File (S.File);
293 end End_Of_Stream;
294
295 package body Calendar is
296
297 -----------------------------------------------
298 -- Time = DOS Time. Valid through Year 2107. --
299 -----------------------------------------------
300
301 procedure Split
302 (Date : Time;
303 To_Year : out Ada.Calendar.Year_Number;
304 To_Month : out Ada.Calendar.Month_Number;
305 To_Day : out Ada.Calendar.Day_Number;
306 To_Seconds : out Ada.Calendar.Day_Duration)
307 is
308 d_date : constant Integer := Integer (Date / 65536);
309 d_time : constant Integer := Integer (Date and 65535);
310 x : Integer;
311 hours : Integer;
312 minutes : Integer;
313 seconds_only : Integer;
314 begin
315 To_Year := 1980 + d_date / 512;
316 x := (d_date / 32) mod 16;
317 if x not in Ada.Calendar.Month_Number then -- that is 0, or in 13..15
318 raise Time_Error;
319 end if;
320 To_Month := x;
321 x := d_date mod 32;
322 if x not in Ada.Calendar.Day_Number then -- that is 0
323 raise Time_Error;
324 end if;
325 To_Day := x;
326 hours := d_time / 2048;
327 minutes := (d_time / 32) mod 64;
328 seconds_only := 2 * (d_time mod 32);
329 if hours not in 0 .. 23 or
330 minutes not in 0 .. 59 or
331 seconds_only not in 0 .. 59
332 then
333 raise Time_Error;
334 end if;
335 To_Seconds := Ada.Calendar.Day_Duration (hours * 3600 + minutes * 60 + seconds_only);
336 end Split;
337 --
338 function Time_Of
339 (From_Year : Ada.Calendar.Year_Number;
340 From_Month : Ada.Calendar.Month_Number;
341 From_Day : Ada.Calendar.Day_Number;
342 From_Seconds : Ada.Calendar.Day_Duration := 0.0) return Time
343 is
344 year_2 : Integer := From_Year;
345 hours : Unsigned_32;
346 minutes : Unsigned_32;
347 seconds_only : Unsigned_32;
348 seconds_day : Unsigned_32;
349 result : Unsigned_32;
350 begin
351 if year_2 < 1980 then -- avoid invalid DOS date
352 year_2 := 1980;
353 end if;
354 seconds_day := Unsigned_32 (From_Seconds);
355 hours := seconds_day / 3600;
356 minutes := (seconds_day / 60) mod 60;
357 seconds_only := seconds_day mod 60;
358 result :=
359 -- MSDN formula for encoding:
360 Unsigned_32 ((year_2 - 1980) * 512 + From_Month * 32 + From_Day) * 65536 -- Date
361 +
362 hours * 2048 + minutes * 32 + seconds_only / 2; -- Time
363 return Time (result);
364 end Time_Of;
365
366 function ">" (Left, Right : Time) return Boolean is
367 begin
368 return Unsigned_32 (Left) > Unsigned_32 (Right);
369 end ">";
370
371 function Convert (Date : in Ada.Calendar.Time) return Time is
372 year_temp : Ada.Calendar.Year_Number;
373 month_temp : Ada.Calendar.Month_Number;
374 day_temp : Ada.Calendar.Day_Number;
375 seconds_day_dur : Ada.Calendar.Day_Duration;
376 begin
377 Ada.Calendar.Split (Date, year_temp, month_temp, day_temp, seconds_day_dur);
378 return Time_Of (year_temp, month_temp, day_temp, seconds_day_dur);
379 end Convert;
380
381 function Convert (Date : in Time) return Ada.Calendar.Time is
382 year_temp : Ada.Calendar.Year_Number;
383 month_temp : Ada.Calendar.Month_Number;
384 day_temp : Ada.Calendar.Day_Number;
385 seconds_day_dur : Ada.Calendar.Day_Duration;
386 begin
387 Split (Date, year_temp, month_temp, day_temp, seconds_day_dur);
388 return Ada.Calendar.Time_Of (year_temp, month_temp, day_temp, seconds_day_dur);
389 end Convert;
390
391 function Convert (Date : in DOS_Time) return Time is
392 begin
393 return Time (Date); -- currently a trivial conversion
394 end Convert;
395
396 function Convert (Date : in Time) return DOS_Time is
397 begin
398 return DOS_Time (Date); -- currently a trivial conversion
399 end Convert;
400
401 end Calendar;
402
403 end Zip_Streams;
Web view of Ada source code generated by GNATHTML, project: ALI_Parse version 1.0.
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other Ada projects
on Gautier's blog.
