1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377 | ---------------------------------------------------------------------
---------------------------------------------------------------------
-- PNG_IO -- Ada95 Portable Network Graphics Input/Output Package --
-- --
-- Copyright (©) 1999 Dr Stephen J. Sangwine (S.Sangwine@IEEE.org) --
-- --
-- This software was created by Stephen J. Sangwine. He hereby --
-- asserts his Moral Right to be identified as author of this --
-- software. --
---------------------------------------------------------------------
---------------------------------------------------------------------
-- PNG_IO is free software; you can redistribute it and/or modify --
-- it under the terms of the GNU General Public License as --
-- published by the Free Software Foundation; either version 2 of --
-- the License, or (at your option) any later version. --
-- --
-- PNG_IO is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --
-- GNU General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public --
-- License along with this software (in the file gpl.txt); if not, --
-- contact the Free Software Foundation, or access www.fsf.org. --
---------------------------------------------------------------------
---------------------------------------------------------------------
-- Date: 26 August 1999 --
-- Edit: 9 September 1999 to insert check on size of uncompressed --
-- data in PNG_IO.Open => Version ".1" --
-- 14 December 1999 to modify version to ".1a" reflecting --
-- minor change in png_io-open.adb --
-- 29 February 2000 to use generic Zlib package, hence 1.2. --
-- 12 July 2000 to change the buffer size calculation --
-- in procedure Write_IDAT_Chunk to use a --
-- more robust calculation added to the --
-- generic_zlib package. This corrects a --
-- buffer overflow for images of more than --
-- 4,290,676 bytes and should now work for --
-- images up to almost 4GB. --
-- 13 July 2000 to make the Write_IDAT_Chunk procedure --
-- use heap-allocated buffers rather than --
-- stack variables, and deallocate the --
-- uncompressed data buffer as soon as the --
-- compressed data has been generated. --
-- 17 July 2000 to change with clause from --
-- Sequential_IO to Direct_IO, to enable --
-- changes in png_io-open.adb. Fixed error --
-- with Type 4 handling in Alpha_Value. --
-- Released as version 1.3. --
-- 1 November 2000 to add the sRGB chunk code and support --
-- for reading the raw data from ancillary --
-- chunks that are not directly supported. --
-- 20 November 2000 to finish code for writing text chunks. --
-- 9 March 2001 to add extra sRGB functions. --
-- 15 May 2002 to add function Sample_Depth, and to --
-- detect unopen file passed to Close and --
-- raise exception. --
-- 24 May 2002 to add code to Adam7 to support output. --
-- 2 June 2003 to fix the Write_PNG_Type_3 parameters --
-- (P was missing from the body stub); --
-- to change the two variables Temp in --
-- Close procedure to constants; --
-- to remove redundant type conversions in --
-- the function Sub_Image_Size. --
-- 9 January 2004 commented out Chunk_Ordering.After_PLTE,--
-- moved the full declaration of Text_Item --
-- ahead of that of PNG_File_Descriptor, --
-- deleted Inline pragma for Interlaced. --
-- 10 January 2004 to add the function Zlib_Version. --
-- 29 June 2004 to fix the Palette function to return --
-- True if a palette was found in the file --
-- rather than just the file was a type 3. --
-- 1 July 2004 to replace the temporary binding to --
-- Zlib with Zlib_Ada, and use Stream_IO. --
-- 10 September 2004 to change version to 4.2, for use with --
-- Zlib_Ada release 1.3. --
-- 25 November 2004 version 4.2.1. --
-- 1 December 2004 added third "&" function for chunks to --
-- return a Chunk_List from two Chunks and --
-- changed version to 4.2.2. Fixed bug in --
-- function Standard_RGB_Chunk. --
-- 3 March 2005 added fourth "&" function to join two --
-- Chunk_Lists. --
-- 12 August 2006 changed the handling of the version and --
-- the Package_Identifier to make PNG_IO --
-- compliant with the Ravenscar profile. --
-- 13 August 2006 references to the PNG Specification 1.2 --
-- amended to refer to the ISO standard. --
-- Moved renaming of Zlib_Version to spec. --
-- 9/10 September 2006 changes due to modifications to Write --
-- procedures to avoid buffering of IDAT --
-- data, using on-the-fly compression. --
---------------------------------------------------------------------
---------------------------------------------------------------------
with Ada.Exceptions;
use Ada.Exceptions;
with Ada.Streams.Stream_IO;
use Ada.Streams.Stream_IO;
with Ada.Unchecked_Deallocation,
Ada.Characters.Latin_1,
Ada.Characters.Handling;
with Interfaces;
use Interfaces;
with PNG_IO.Chromaticity_Data;
with PNG_IO.Adam7;
use PNG_IO.Adam7;
package body PNG_IO is
-- 12 August 2006 : the way the version number is declared was changed in order
-- to make PNG_IO comply with the Ravenscar profile (at least under Gnat/gcc -
-- since there are some implementation dependencies in this profile). Thanks
-- to Samuel Tardieu for pointing out that PNG_IO was almost Ravenscar compliant
-- and that only a small change would be needed to make it so.
Version_String : constant String := "4.4";
function Version return String is begin return Version_String; end;
---------------------------------------------------------
function Valid_Zlib_Header(CMG, FLG : in Stream_Element) return Boolean is
-- This function checks the data in the first two bytes of a Zlib
-- data stream, supplied as the two parameters. (ISO standard, section 10.1.)
-- We check the least significant 4 bits of CMG (the first byte)
-- and that the overall 16-bit value is a multiple of 31 as required
-- by RFC1950 (the Zlib Compressed Data Format Specification).
begin
return (CMG and 2#1111#) = 8
and (Unsigned_16(CMG) * 256 + Unsigned_16(FLG)) mod 31 = 0;
end Valid_Zlib_Header;
----------------------
-- All PNG files have the same initial 8 bytes (the signature):
PNG_Signature : constant Stream_Element_Array := (16#89#, 16#50#, 16#4E#, 16#47#,
16#0D#, 16#0A#, 16#1A#, 16#0A#);
----------------------------------------------------------------------
-- PNG files written by this package contain the following text in a
-- tEXt chunk to indicate the software that wrote the chunk.
Package_Identifier : constant String := "Software"
& Ada.Characters.Latin_1.NUL
& "PNG_IO Version " & Version_String
& " by Steve Sangwine (S.Sangwine@IEEE.org).";
-------------------------------------------------------------------------
IDAT_Size : constant := 8 * 2**10; -- This determines the maximum size of
-- IDAT chunk that will be output.
-------------------------------------------------------------------------
-- A PNG file can contain various chunks, each with a 4-byte chunk type
-- code. The chunk type codes are defined here numerically, so that they
-- are static, but they are verified at the end of this body in the package
-- initialisation code so that errors in the coding of the numerical values
-- are trapped. If any new codes are added the verification code must also
-- be added. PNG type codes are defined in terms of ISO 8859-1 Latin-1
-- character codes as are the codes for the Ada95 package Standard listed
-- in LRM Section A.1 from which the following table is derived:
-- x = 0123456789ABCDEF
-- 16#4x# ABCDEFGHIJKLMNO
-- 16#5x# PQRSTUVWXYZ
-- 16#6x# abcdefghijklmno
-- 16#7x# pqrstuvwxyz
IHDR : constant := 16#49484452#;
PLTE : constant := 16#504C5445#;
IDAT : constant := 16#49444154#;
IEND : constant := 16#49454E44#;
tRNS : constant := 16#74524E53#;
gAMA : constant := 16#67414D41#;
cHRM : constant := 16#6348524D#;
sRGB : constant := 16#73524742#;
iCCP : constant := 16#69434350#;
tEXt : constant := 16#74455874#;
zTXt : constant := 16#7A545874#;
iTXt : constant := 16#69545874#;
bKGD : constant := 16#624B4744#;
pHYs : constant := 16#70485973#;
sBIT : constant := 16#73424954#;
sPLT : constant := 16#73504C54#;
hIST : constant := 16#68495354#;
tIME : constant := 16#74494D45#;
--------------------------------
function To_Chunk_Name(C : Unsigned_32) return Chunk_Name is
begin
return Character'Val((Shift_Right(C, 24) and 16#FF#)) &
Character'Val((Shift_Right(C, 16) and 16#FF#)) &
Character'Val((Shift_Right(C, 8) and 16#FF#)) &
Character'Val( C and 16#FF#);
end To_Chunk_Name;
function To_Unsigned_32(N : Chunk_Name) return Unsigned_32 is
B1 : constant Unsigned_32 := Shift_Left(Character'Pos(N(1)), 24);
B2 : constant Unsigned_32 := Shift_Left(Character'Pos(N(2)), 16);
B3 : constant Unsigned_32 := Shift_Left(Character'Pos(N(3)), 8);
B4 : constant Unsigned_32 := Character'Pos(N(4));
begin
return B1 or B2 or B3 or B4;
end To_Unsigned_32;
-------------------------
package Chunk_Ordering is
-- An encoding/LUT of the rules laid out in the ISO standard
-- (Section 5.6 and Table 5.3). This should not be confused with the
-- three positions available to the user of PNG_IO when writing a
-- file (before the PLTE, between PLTE and IDAT, and after IDAT).
function Known_Chunk(C : Unsigned_32) return Boolean;
function Before_PLTE(C : Unsigned_32) return Boolean;
--function After_PLTE(C : Unsigned_32) return Boolean; -- Not currently used.
function Before_IDAT(C : Unsigned_32) return Boolean;
end Chunk_Ordering;
use Chunk_Ordering;
package body Chunk_Ordering is separate;
----------------------------------------
function Known_Chunk(Name : Chunk_Name) return Boolean is
begin
return Known_Chunk(To_Unsigned_32(Name));
end Known_Chunk;
function Position(C : Unsigned_32) return Chunk_Position is
-- Gives the position in terms of the three choices available
-- to the user. The choice is a priority encoding of the positions
-- defined in the PNG specification.
begin
if Before_PLTE(C) then
return Before_PLTE;
elsif Before_IDAT(C) then
return Before_IDAT; -- This means after PLTE if it exists.
else
return Anywhere;
end if;
end Position;
function Position(Name : Chunk_Name) return Chunk_Position is
C : constant Unsigned_32 := To_Unsigned_32(Name);
begin
if Known_Chunk(C) then
return Position(C);
else
raise Argument_Error;
end if;
end Position;
-------------------------------------------------------------
-- We also need to be able to check other chunk types to make
-- sure they are ancillary (bit 5 of the first byte is set).
function Ancillary(C : Unsigned_32) return Boolean is
begin
return (C and 2#00100000_00000000_00000000_00000000#) /= 0;
end Ancillary;
function Safe_to_Copy(C : Unsigned_32) return Boolean is
-- An internal function which tests bit 5 of the least significant
-- byte of a chunk type (the safe to copy bit).
begin
return (C and 2#00000000_00000000_00000000_00100000#) /= 0;
end Safe_to_Copy;
pragma Inline(Safe_to_Copy);
function Safe_to_Copy(C : Chunk) return Boolean is
-- The function visible outside the package.
begin
return Safe_to_Copy(To_Unsigned_32(C.Name));
end Safe_to_Copy;
------------------------------------
-- Define the PNG filter type codes.
None : constant := 0;
Sub : constant := 1;
Up : constant := 2;
Average : constant := 3;
Paeth : constant := 4;
-------------------------------------------------------------------------------------------
-- Look up tables for converting bit depths and colour type codes to bytes.
Bit_Depth_Table : constant array(Depth) of Stream_Element := (1, 2, 4, 8, 16);
Colour_Type_Table : constant array(Colour_Type_Code) of Stream_Element := (0, 2, 3, 4, 6);
-------------------------------------------------------------------------------------------
type Palette_Data is array(Unsigned_8 range <>) of Unsigned_8;
type Colour_Palette(Size : Unsigned_8) is
record
R, G, B : Palette_Data(0 .. Size);
end record;
type Palette_Pointer is access Colour_Palette;
subtype Buffer is Stream_Element_Array;
type Buffer_Pointer is access Buffer;
subtype Buffer_2 is Buffer(1 .. 2); -- I.e. 2 bytes, 16 bits.
subtype Buffer_4 is Buffer(1 .. 4); -- I.e. 4 bytes, 32 bits.
function To_Buffer_2(U : Unsigned_16) return Buffer_2 is
begin
return Stream_Element(Shift_Right(U and 16#FF00#, 8))
& Stream_Element( U and 16#00FF# );
end To_Buffer_2;
function To_Buffer_4(U : Unsigned_32) return Buffer_4 is
B : Buffer_4;
L : Unsigned_32 := U;
begin
for I in reverse B'Range loop
B(I) := Stream_Element(L and 16#FF#);
exit when I = B'First;
L := Shift_Right(L, 8);
end loop;
return B;
end To_Buffer_4;
-- The Text_Item type is used to store a keyword/text string pair and a
-- link pointer. Text strings are stored in a linked list with the
-- head pointer in the PNG_File_Descriptor. This is awkward, but
-- since the number of these strings is not defined, and they are
-- of variable length, it is difficult to see what else to do.
type String_Pointer is access String;
type Text_Item;
type Text_Item_Pointer is access Text_Item;
type Text_Item is
record
Keyword : String_Pointer;
Text_String : String_Pointer;
Link : Text_Item_Pointer;
end record;
type Pass_Offsets is array(Pass_Number) of Stream_Element_Offset;
type PNG_File_Descriptor is
record
Handle : File_Type;
Stream : Stream_Access;
Width,
Height : Dimension;
Bit_Depth,
Colour_Type,
Compression,
Filter,
Interlace : Unsigned_8;
Gamma : Boolean := False;
Gamma_Value : Unsigned_32;
Chroma : Boolean := False;
White_X, White_Y,
Red_X, Red_Y,
Green_X, Green_Y,
Blue_X, Blue_Y : Unsigned_32;
SRGB : Boolean := False;
Rendering : Rendering_Intent;
Physical : Boolean := False;
Phys_X, Phys_Y : Unsigned_32;
Phys_Unit : Unsigned_8;
Number_of_Texts : Natural := 0;
Text_Strings : Text_Item_Pointer;
Number_of_Chunks : Natural := 0; -- Unrecognised ancillary chunks
Ancillary_Chunks : Chunk_List; -- are tacked on here as a list.
Palette : Palette_Pointer;
Uncompressed_Data : Buffer_Pointer;
Interlace_Offsets : Pass_Offsets;
end record;
procedure Deallocate is new Ada.Unchecked_Deallocation(Buffer, Buffer_Pointer);
function To_Stream_Element_Array(S : String) return Stream_Element_Array is
B : Stream_Element_Array(1 .. S'Length);
I : Stream_Element_Offset := B'First;
J : Positive := S'First;
begin
loop
B(I) := Stream_Element(Character'Pos(S(J)));
exit when J = S'Last;
I := I + 1; J := J + 1;
end loop;
return B;
end To_Stream_Element_Array;
To_Stream_Element : constant array(Boolean) of Stream_Element := (0, 1);
procedure Check(F : in PNG_File) is
-- Checks that the file descriptor F exists.
begin
if F = null then
Raise_Exception(Call_Error'Identity,
"Attempt to access non-existent file descriptor.");
end if;
end Check;
pragma Inline(Check);
function Bits_per_Pixel(Colour_Type : Colour_Type_Code;
Bit_Depth : Depth) return Positive is
-- The number of bits per pixel in the IDAT chunks. This is not
-- always the same as the number of bits per pixel in the image.
-- The only exception is that there are 24 bits per pixel for
-- images of colour type 3 (palette colour).
BD : constant Positive := Positive(Bit_Depth_Table(Bit_Depth));
begin
case Colour_Type is
when Zero => return BD; -- Greyscale.
when Two => return BD * 3; -- RGB
when Three => return BD; -- Palette colour.
when Four => return BD * 2; -- Greyscale + alpha.
when Six => return BD * 4; -- RGB + alpha.
end case;
end;
pragma Inline(Bits_per_Pixel);
function Bytes_per_Pixel(Colour_Type : Colour_Type_Code;
Bit_Depth : Depth) return Positive is
-- The number of bytes in each pixel rounded up to 1 for bit depths
-- less than 8. Used in filtering scanlines where it defines the
-- offset between one byte and the corresponding byte from the next
-- pixel, or containing the next pixel.
begin
return Positive'Max(1, (Bits_per_Pixel(Colour_Type, Bit_Depth))/8);
end Bytes_per_Pixel;
pragma Inline(Bytes_per_Pixel);
function Bytes_per_Scanline(Colour_Type : Colour_Type_Code;
Bit_Depth : Depth;
Scanline_Width : Dimension) return Stream_Element_Count is
-- The number of bytes per scanline (excluding the filter type
-- byte) must allow for pixels of less than 8 bits with image
-- widths which do not result in an integral number of bytes.
-- We round up the number of bytes by adding 7 to the number
-- of bits.
begin
return Stream_Element_Count(Bits_per_Pixel(Colour_Type, Bit_Depth) * Scanline_Width + 7)/8;
end;
pragma Inline(Bytes_per_Scanline);
function Image_Size(Colour_Type : Colour_Type_Code;
Bit_Depth : Depth;
X, Y : Dimension;
Interlaced : Boolean) return Stream_Element_Count is
-- Computes the size of image data in bytes, taking account of
-- wasted bits, filter type bytes and interlacing, for use in
-- allocating buffers.
function Sub_Image_Size(W, H : Natural) return Stream_Element_Count is
begin
if W = 0 or H = 0 then
return 0; -- Empty pass: see PNG Specification Section 2.6.
else
-- The + 1 in the next line is to allow for the filter type byte.
return Stream_Element_Count(H) * (Bytes_per_Scanline(Colour_Type, Bit_Depth, W) + 1);
end if;
end Sub_Image_Size;
pragma Inline(Sub_Image_Size);
begin
if not Interlaced then
return Sub_Image_Size(X, Y);
else
declare
R : Stream_Element_Count := 0;
begin
for P in Pass_Number loop
R := R + Sub_Image_Size(Sub_Image_Width(X, P), Sub_Image_Height(Y, P));
end loop;
return R;
end;
end if;
end Image_Size;
function Interlaced(F : PNG_File) return Boolean is
begin
return F.Interlace = 1; -- Simplified 26 May 2002. The byte can only be 0 or 1.
end Interlaced;
function Mean(X, Y : Stream_Element) return Stream_Element is
-- Function to compute the mean value used in the Average
-- filter described in the ISO standard, Section 9.2 and Table 9.1.
type Nine_Bit is mod 2**9;
begin
return Stream_Element((Nine_Bit(X) + Nine_Bit(Y))/2);
end;
pragma Inline(Mean);
function PaethPredictor(A, B, C : Stream_Element) return Stream_Element is
-- This code is based on the pseudocode given in the ISO standard, Section 9.4.
P : constant Integer := Integer(A) + Integer(B) - Integer(C);
PA : constant Integer := abs(P - Integer(A));
PB : constant Integer := abs(P - Integer(B));
PC : constant Integer := abs(P - Integer(C));
begin
if PA <= PB and PA <= PC then return A;
elsif PB <= PC then return B;
else return C;
end if;
end PaethPredictor;
pragma Inline(PaethPredictor);
function Width(F : PNG_File) return Dimension is
begin
Check(F); return F.Width;
end;
function Height(F : PNG_File) return Dimension is
begin
Check(F); return F.Height;
end;
function Bit_Depth(F : PNG_File) return Depth is
begin
Check(F);
case F.Bit_Depth is
when 1 => return One;
when 2 => return Two;
when 4 => return Four;
when 8 => return Eight;
when 16 => return Sixteen;
when others => -- Since F.Bit_Depth was validated when the IHDR chunk
-- was read by Open, this simply should not happen. So
raise Program_Error;
end case;
end;
function Sample_Depth(F : PNG_File) return Positive is
begin
if Colour_Type(F) /= Three then
return Positive(Bit_Depth_Table(Bit_Depth(F)));
else -- The image is a palette image and the number of
return 8; -- bits per sample is independent of bit depth.
end if;
end Sample_Depth;
function Colour_Type(F : PNG_File) return Colour_Type_Code is
begin
Check(F);
declare
T : Unsigned_8 renames F.Colour_Type;
begin
if T = 0 then return Zero;
elsif T = 2 then return Two;
elsif T = 3 then return Three;
elsif T = 4 then return Four;
elsif T = 6 then return Six;
else raise Program_Error;
end if;
end;
end;
function Palette(F : PNG_File) return Boolean is
-- The test here was modified 29 June 2004. Previously
-- it checked for a colour type of 3 rather than for the
-- presence of a palette. (Colour types 2 and 6 can have
-- an optional palette.)
begin
Check(F); return F.Palette /= null;
end;
function Palette_Size(F : PNG_File) return Positive is
begin
return Positive(Natural(F.Palette.Size) + 1);
end Palette_Size;
-- Palette indices run from 0 .. Size - 1;
function Palette_R_Value(F : PNG_File; Index : Natural) return Natural is
begin
if Unsigned_8(Index) <= F.Palette.Size then
return Natural(F.Palette.R(Unsigned_8(Index)));
else
Raise_Exception(Call_Error'Identity, "Palette index out of range.");
end if;
end Palette_R_Value;
function Palette_G_Value(F : PNG_File; Index : Natural) return Natural is
begin
if Unsigned_8(Index) <= F.Palette.Size then
return Natural(F.Palette.G(Unsigned_8(Index)));
else
Raise_Exception(Call_Error'Identity, "Palette index out of range.");
end if;
end Palette_G_Value;
function Palette_B_Value(F : PNG_File; Index : Natural) return Natural is
begin
if Unsigned_8(Index) <= F.Palette.Size then
return Natural(F.Palette.B(Unsigned_8(Index)));
else
Raise_Exception(Call_Error'Identity, "Palette index out of range.");
end if;
end Palette_B_Value;
procedure Open(F : in out PNG_File; Filename : in String) is separate;
procedure Close(F : in out PNG_File) is
-- Called by the user but also in the event of an exception during Open.
procedure Deallocate is new Ada.Unchecked_Deallocation(Colour_Palette, Palette_Pointer);
procedure Deallocate is new Ada.Unchecked_Deallocation(Text_Item, Text_Item_Pointer);
procedure Deallocate is new Ada.Unchecked_Deallocation(PNG_File_Descriptor, PNG_File);
procedure Deallocate is new Ada.Unchecked_Deallocation(Chunk_List_Element, Chunk_List);
begin
if F = null then
-- The file is not open or has not been opened (it might already have been closed.)
-- The standard packages such as Ada.Direct_IO raise Status_Error in this situation
-- so we do the same here. We cannot allow this to go undetected, otherwise we will
-- get exceptions in the following code when we attempt to access elements of the
-- record (not) accessed by F.
Raise_Exception(Status_Error'Identity, "Attempt to close non-open file.");
end if;
-- Deallocate has no effect if the access value is null. LRM 13.11.2(8)
Deallocate(F.Palette);
Deallocate(F.Uncompressed_Data);
while F.Ancillary_Chunks /= null loop
declare
Temp : constant Chunk_List := F.Ancillary_Chunks.Link;
begin
Deallocate(F.Ancillary_Chunks); F.Ancillary_Chunks := Temp;
end;
end loop;
while F.Text_Strings /= null loop
declare
Temp : constant Text_Item_Pointer := F.Text_Strings.Link;
begin
Deallocate(F.Text_Strings); F.Text_Strings := Temp;
end;
end loop;
if Is_Open(F.Handle) then Close(F.Handle); end if;
Deallocate(F);
end Close;
function Pixel_Index(F : PNG_File; R, C : Coordinate) return Stream_Element_Offset is
-- A function to compute the index in the uncompressed data buffer
-- of the first byte containing the pixel at position R, C. Note
-- that the pixel itself may occupy more or less than a whole byte.
begin
Check(F); -- Make sure F exists.
if R + 1 > F.Height or C + 1 > F.Width then
Raise_Exception(Constraint_Error'Identity, "Coordinate(s) out of range.");
end if;
declare
function Index(R, C : Coordinate; W : Dimension) return Stream_Element_Offset is
-- Computes the index of the desired byte within the image or sub-image.
CT : constant Colour_Type_Code := Colour_Type(F);
BD : constant Depth := Bit_Depth(F);
Bpp : constant Positive := Bits_per_Pixel(CT, BD);
begin
return 1 + Stream_Element_Offset(R) * Stream_Element_Offset(Bytes_per_Scanline(CT, BD, W) + 1)
+ 1 + (Stream_Element_Offset(C) * Stream_Element_Offset(Bpp))/8;
end Index;
pragma Inline(Index);
W : constant Dimension := Width(F);
begin
if not Interlaced(F) then
return Index(R, C, W);
else
declare
P : constant Pass_Number := Pass(R, C);
begin
return F.Interlace_Offsets(P) - 1
+ Index(Sub_Image_Row(R, C), Sub_Image_Col(R, C), Sub_Image_Width(W, P));
end;
end if;
end;
end Pixel_Index;
pragma Inline(Pixel_Index);
-- Low-level functions to fetch the byte/word at a given coordinate in the image.
-- The offset allows for colour and alpha bytes/words to be fetched.
function U8(F : PNG_File; R, C : Coordinate; Offset : Stream_Element_Offset := 0) return Unsigned_8 is
begin
return Unsigned_8(F.Uncompressed_Data(Pixel_Index(F, R, C) + Offset));
end U8;
pragma Inline(U8);
function U16(F : PNG_File; R, C : Coordinate; Offset : Stream_Element_Offset := 0) return Unsigned_16 is
P : constant Stream_Element_Offset := Pixel_Index(F, R, C) + Offset;
D : Stream_Element_Array renames F.Uncompressed_Data.all;
begin
return Shift_Left(Unsigned_16(D(P)), 8) or Unsigned_16(D(P + 1));
end U16;
pragma Inline(U16);
-- Low-level function to fetch bits, half nibbles or nibbles at a given coordinate
-- in the image. Since the leftmost pixels are in the high order bits of the byte
-- ISO standard, Section 7.2), we have to reverse the position by subtraction from 7/3/1.
-- Modified 18 July 2000 to change BD from Depth_1_2_4 to Unsigned_8 for efficiency.
function U1_2_4(F : PNG_File;
R, C : Coordinate;
BD : Unsigned_8) return Unsigned_8 is
B : constant Unsigned_8 := U8(F, R, C); -- The byte containing the pixel.
T : constant array(Boolean) of Coordinate := (False => C,
True => Sub_Image_Col(R, C));
K : constant Coordinate := T(Interlaced(F));
begin
case BD is
when 1 => return Shift_Right(B, 7 - (K rem 8)) and 2#0000_0001#;
when 2 => return Shift_Right(B, 2 * (3 - (K rem 4))) and 2#0000_0011#;
when 4 => return Shift_Right(B, 4 * (1 - (K rem 2))) and 2#0000_1111#;
when others => raise Program_Error;
end case;
end U1_2_4;
pragma Inline(U1_2_4);
-- Because the following functions will be called a very large number of
-- times there is limited error checking of the values in order not to
-- slow down image reading. These functions were modified 18 July 2000 to
-- remove calls to Bit_Depth and replace these with F.Bit_Depth because
-- this is more efficient.
function Palette_Index(F : PNG_File; R, C : Coordinate) return Unsigned_8 is
function Validate(I : Unsigned_8) return Unsigned_8 is
begin
if I > F.Palette.Size then
Raise_Exception(Format_Error'Identity, "Invalid pixel data in palette image.");
else
return I;
end if;
end Validate;
pragma Inline(Validate);
begin
case F.Bit_Depth is
when 1 | 2 | 4 => return Validate(U1_2_4(F, R, C, F.Bit_Depth));
when 8 => return Validate( U8(F, R, C));
when others => raise Program_Error; -- Since the PLTE chunk was checked on
end case; -- reading this shouldn't happen.
end Palette_Index;
pragma Inline(Palette_Index);
function Pixel_Value(F : PNG_File; R, C : Coordinate) return Natural is
begin
if F.Colour_Type = 3 then
return Natural(Palette_Index(F, R, C));
else
case F.Bit_Depth is
when 1 | 2 | 4 => return Natural(U1_2_4(F, R, C, F.Bit_Depth));
when 8 => return Natural( U8(F, R, C));
when 16 => return Natural( U16(F, R, C));
when others => raise Program_Error; -- This shouldn't happen.
end case;
end if;
end Pixel_Value;
function Red_Value(F : PNG_File; R, C : Coordinate) return Natural is
begin
if F.Colour_Type = 3 then
return Natural(F.Palette.R(Palette_Index(F, R, C)));
else
case F.Bit_Depth is
when 8 => return Natural(U8 (F, R, C));
when 16 => return Natural(U16(F, R, C));
when others => raise Call_Error;
end case;
end if;
end Red_Value;
function Green_Value(F : PNG_File; R, C : Coordinate) return Natural is
begin
if F.Colour_Type = 3 then
return Natural(F.Palette.G(Palette_Index(F, R, C)));
else
case F.Bit_Depth is
when 8 => return Natural(U8 (F, R, C, 1));
when 16 => return Natural(U16(F, R, C, 2));
when others => raise Call_Error;
end case;
end if;
end Green_Value;
function Blue_Value(F : PNG_File; R, C : Coordinate) return Natural is
begin
if F.Colour_Type = 3 then
return Natural(F.Palette.B(Palette_Index(F, R, C)));
else
case F.Bit_Depth is
when 8 => return Natural(U8 (F, R, C, 2));
when 16 => return Natural(U16(F, R, C, 4));
when others => raise Call_Error;
end case;
end if;
end Blue_Value;
function Alpha_Value(F : PNG_File; R, C : Coordinate) return Natural is
-- This function may be called for a Type 4 or Type 6 PNG. Prior to
-- version 1.3, this function gave incorrect values for Type 4 PNGs
-- because it did not take account of the PNG type and the offsets
-- supplied to U8/16 were for Type 6 RGBA images.
begin
case F.Colour_Type is
when 4 =>
case F.Bit_Depth is
when 8 => return Natural(U8 (F, R, C, 1));
when 16 => return Natural(U16(F, R, C, 2));
when others => raise Call_Error;
end case;
when 6 =>
case F.Bit_Depth is
when 8 => return Natural(U8 (F, R, C, 3));
when 16 => return Natural(U16(F, R, C, 6));
when others => raise Call_Error;
end case;
when others => raise Call_Error;
end case;
end Alpha_Value;
function Gamma(F : PNG_File) return Boolean is begin return F.Gamma; end;
function Gamma_Value(F : PNG_File) return Natural is
begin
if F.Gamma then return Natural(F.Gamma_Value);
else raise Call_Error;
end if;
end;
function Chromaticity(F : PNG_File) return Boolean is
begin
return F.Chroma;
end;
function White_Point(F : PNG_File) return Pair is
begin
if F.Chroma then return (Positive(F.White_X), Positive(F.White_Y));
else raise Call_Error;
end if;
end;
function Red_Primary(F : PNG_File) return Pair is
begin
if F.Chroma then return (Positive(F.Red_X), Positive(F.Red_Y));
else raise Call_Error;
end if;
end;
function Green_Primary(F : PNG_File) return Pair is
begin
if F.Chroma then return (Positive(F.Green_X), Positive(F.Green_Y));
else raise Call_Error;
end if;
end;
function Blue_Primary(F : PNG_File) return Pair is
begin
if F.Chroma then return (Positive(F.Blue_X), Positive(F.Blue_Y));
else raise Call_Error;
end if;
end;
function Standard_RGB(F : PNG_File) return Boolean is
begin
return F.SRGB;
end Standard_RGB;
function SRGB_Rendering(F : PNG_File) return Rendering_Intent is
begin
if F.SRGB then return F.Rendering; else raise Call_Error; end if;
end SRGB_Rendering;
function Standard_RGB_Chunk(R : Rendering_Intent) return Chunk is
begin
return Chunk'(1, To_Chunk_Name(sRGB),
Stream_Element_Array'(1 => Rendering_Intent'Pos(R)), Before_PLTE);
end Standard_RGB_Chunk;
function Standard_RGB_Chroma return Chunk is
use Chromaticity_Data;
begin
return Chromaticity_Chunk(D65, BT709_R, BT709_G, BT709_B);
end Standard_RGB_Chroma;
function Standard_RGB_Gamma return Chunk is
-- The gamma value used here is laid down in the PNG Specification V1.2, p22.
begin
return Gamma_Chunk(Gamma_2_2);
end Standard_RGB_Gamma;
function Physical(F : PNG_File) return Boolean is
begin
return F.Physical;
end;
function Unit_Unknown(F : PNG_File) return Boolean is
begin
if F.Physical then return F.Phys_Unit = 0;
else raise Call_Error;
end if;
end;
function Unit_Meter(F : PNG_File) return Boolean is
begin
if F.Physical then return F.Phys_Unit = 1;
else raise Call_Error;
end if;
end;
function Physical_Value(F : PNG_File) return Pair is
begin
if F.Physical then return (Positive(F.Phys_X), Positive(F.Phys_Y));
else raise Call_Error;
end if;
end;
function NTexT(F : PNG_File) return Natural is
begin
return F.Number_of_Texts;
end;
function TextN(F : PNG_File; N : Positive) return Text_Item_Pointer is
P : Text_Item_Pointer := F.Text_Strings; -- May be null.
begin
if N <= F.Number_of_Texts then
-- We work through the list here in reverse order. If N = F.Text_Strings
-- we return the first list item, if N = 1 we return the last. (The list
-- was added to at the head so the first item is the last text string
-- found in the file.
for I in 1 .. F.Number_of_Texts - N loop P := P.Link; end loop;
return P;
else
Raise_Exception(Call_Error'Identity, "String index too large.");
end if;
end TextN;
pragma Inline(TextN);
function Text_Keyword(F : PNG_File; N : Positive) return String is
begin
return TextN(F, N).Keyword.all;
end;
function Text_String(F : PNG_File; N : Positive) return String is
begin
return TextN(F, N).Text_String.all;
end;
function Ancillary_Chunk_Count(F : PNG_File) return Natural is
begin
return F.Number_of_Chunks;
end Ancillary_Chunk_Count;
function Ancillary_Chunk(F : PNG_File; N : Positive) return Chunk is
P : Chunk_List := F.Ancillary_Chunks; -- May be null.
begin
if N <= F.Number_of_Chunks then
-- We work through the list here in reverse order. If N = F.Number_of_Chunks
-- we return the first list item, if N = 1 we return the last. (The list
-- was added to at the head so the first item is the last chunk found in
-- the file.
for I in 1 .. F.Number_of_Chunks - N loop P := P.Link; end loop;
return P.Chnk;
else
Raise_Exception(Argument_Error'Identity, "Chunk index too large.");
end if;
end Ancillary_Chunk;
function Name(C : Chunk) return Chunk_Name is begin return C.Name; end Name;
function Data(C : Chunk) return Stream_Element_Array is begin return C.Data; end Data;
procedure Destroy(L : in out Chunk_List) is
T : Chunk_List;
procedure Deallocate is new Ada.Unchecked_Deallocation(Chunk_List_Element, Chunk_List);
begin
while L /= Null_Chunk_List loop
T := L; L := L.Link;
Deallocate(T);
end loop;
end Destroy;
function To_Chunk_List(C : Chunk) return Chunk_List is
begin
return new Chunk_List_Element'(C.Size, C, Null_Chunk_List);
end To_Chunk_List;
function "&"(Left, Right : Chunk) return Chunk_List is
begin
return To_Chunk_List(Left) & Right;
end "&";
function "&"(Left : Chunk; Right : Chunk_List) return Chunk_List is
begin
return new Chunk_List_Element'(Left.Size, Left, Right);
end "&";
function "&"(Left : Chunk_List; Right : Chunk) return Chunk_List is
begin
return Left & To_Chunk_List(Right);
end "&";
function "&"(Left, Right : Chunk_List) return Chunk_List is
begin
if Left = Null_Chunk_List then
-- The user supplied a null list on the left. We handle this without
-- complaint and return the right list (which might be null, but not
-- a problem if it is).
return Right;
end if;
-- Otherwise, we need to feel our way down to the end of the Left list and
-- tack Right onto the end. If Right is null, this will have no effect.
declare
T : Chunk_List := Left; -- This cannot be null, because
pragma Assert(T /= null); -- we checked just above.
begin
while T.Link /= Null_Chunk_List loop T := T.Link; end loop;
T.Link := Right;
return Left;
end;
end "&";
function Ancillary_Chunk(Name : Chunk_Name;
Data : Stream_Element_Array;
Where : Chunk_Position) return Chunk is
N : constant Unsigned_32 := To_Unsigned_32(Name);
begin
if not Ancillary(N) then
Raise_Exception(Argument_Error'Identity,
"Chunk name does not denote an ancillary chunk.");
end if;
-- If the chunk name is known to PNG_IO, verify the given chunk position.
if Known_Chunk(N) and then Position(N) /= Where then
Raise_Exception(Argument_Error'Identity,
"Position for chunk " & Name & " should be " & Chunk_Position'Image(Position(N)));
end if;
return (Data'Length, Name, Data, Where);
end;
function Gamma_Chunk(Gamma : Natural := Unity_Gamma) return Chunk is
-- Perhaps it would be wise to do some sort of sanity check on Gamma?
-- On the other hand, the PNG specification allows a 4-byte value and
-- doesn't specify any constraints on the value.
begin
return Chunk'(4, To_Chunk_Name(gAMA), To_Buffer_4(Unsigned_32(Gamma)), Before_PLTE);
end Gamma_Chunk;
function Text_Chunk(Keyword, Text : String) return Chunk is
-- This function should create a compressed text chunk if
-- the text is more than 1024 characters long, but for now
-- it doesn't.
L : constant Stream_Element_Count := Keyword'Length + 1 + Text'Length;
use Ada.Characters.Latin_1;
begin
-- Check the keyword for validity. (ISO standard, Section 11.3.4.2).
if Keyword'Length = 1 -- There must be at least one character.
or else Keyword(Keyword'First) = Space -- Leading spaces are not permitted.
or else Keyword(Keyword'Last) = Space -- Trailing spaces ditto.
then
Raise_Exception(Data_Error'Identity,
"Illegal use of spaces in text chunk keyword.");
end if;
for I in Keyword'Range loop
if Keyword(I) = No_Break_Space then
Raise_Exception(Data_Error'Identity,
"Illegal non-break space character in text chunk keyword.");
elsif not Ada.Characters.Handling.Is_Graphic(Keyword(I)) then
Raise_Exception(Data_Error'Identity,
"Illegal non-graphic character in text chunk keyword.");
end if;
end loop;
-- All seems OK with the keyword, create the chunk.
return Chunk'(L, To_Chunk_Name(PNG_IO.tEXt), -- The chunk code, not the parameter Text!
To_Stream_Element_Array(Keyword & NUL & Text), Anywhere);
end Text_Chunk;
function Chromaticity_Chunk(White_Point, Red_Primary,
Green_Primary, Blue_Primary : Pair) return Chunk is
D : constant Stream_Element_Array := To_Buffer_4(Unsigned_32( White_Point.X))
& To_Buffer_4(Unsigned_32( White_Point.Y))
& To_Buffer_4(Unsigned_32( Red_Primary.X))
& To_Buffer_4(Unsigned_32( Red_Primary.Y))
& To_Buffer_4(Unsigned_32(Green_Primary.X))
& To_Buffer_4(Unsigned_32(Green_Primary.Y))
& To_Buffer_4(Unsigned_32( Blue_Primary.X))
& To_Buffer_4(Unsigned_32( Blue_Primary.Y));
begin
return Chunk'(D'Length, To_Chunk_Name(cHRM), D, Before_PLTE);
end Chromaticity_Chunk;
function Physical_Chunk(Value : Pair; Metre : Boolean) return Chunk is
D : constant Stream_Element_Array := To_Buffer_4(Unsigned_32(Value.X))
& To_Buffer_4(Unsigned_32(Value.Y))
& To_Stream_Element(Metre);
begin
return Chunk'(D'Length, To_Chunk_Name(pHYs), D, Before_IDAT);
end Physical_Chunk;
-- Procedures for writing PNG files. There are variants of the user visible generics
-- for each type of PNG file and for 8-bit and 16-bit sample sizes.
-- However, most of the actual code for file output is common.
-- The procedure Write_Chunk is responsible for computing the CRC of the chunk, as
-- well as the length.
Null_Stream_Element_Array : constant Stream_Element_Array(1 .. 0) := (others => 0);
procedure Write_Chunk(F : in File_Type;
Chunk_Code : in Unsigned_32;
Chunk_Data : in Stream_Element_Array := Null_Stream_Element_Array) is
begin
Write(F, To_Buffer_4(Chunk_Data'Length));
declare
CRC : Zlib.Unsigned_32 := 0;
begin
-- Convert the chunk code to an array of bytes, and calculate its CRC.
declare
CC : constant Buffer_4 := To_Buffer_4(Chunk_Code);
begin
Zlib.CRC32(CRC, CC);
Write(F, CC);
end;
-- The chunk data field can be empty (example, the IEND chunk)
-- in which case a null buffer will be supplied, and we write
-- nothing to the file.
if Chunk_Data'Length > 0 then
Zlib.CRC32(CRC, Chunk_Data);
Write(F, Chunk_Data);
end if;
Write(F, To_Buffer_4(Unsigned_32(CRC)));
end;
end Write_Chunk;
pragma Inline(Write_Chunk);
procedure Start_File(Filename : in String;
X, Y : in Dimension;
CT : in Colour_Type_Code;
BD : in Depth;
Interlace : in Boolean;
F : out File_Type;
Compressor : in out Zlib.Filter_Type;
Level : in Zlib.Compression_Level) is
-- This procedure creates the PNG file and writes the PNG signature and
-- IHDR chunk to the file. The chunk data is small, and is constructed
-- as a constant array on the stack. The procedure also initialises the
-- Zlib compressor used to compress the IDAT data.
begin
Zlib.Deflate_Init(Compressor, Level);
Create(F, Out_File, Filename);
Write (F, PNG_Signature);
declare
Chunk_Data : constant Stream_Element_Array := To_Buffer_4(Unsigned_32(X)) &
To_Buffer_4(Unsigned_32(Y)) &
Bit_Depth_Table(BD) &
Colour_Type_Table(CT) &
0 & -- Compression method.
0 & -- Filter method.
To_Stream_Element(Interlace);
begin
Write_Chunk(F, IHDR, Chunk_Data);
end;
end Start_File;
pragma Inline(Start_File);
-- Zlib calls the callback procedure below to output compressed data. The callback
-- is passed to Zlib in each of the procedures Write_PNG_Type_X. Normally the action
-- of the procedure is to output an IDAT chunk containing whatever data it is given.
-- However, Zlib passes only two bytes of data on the first call (the Zlib header)
-- and it would be a shame to output an IDAT chunk with only two bytes of data, so
-- we cache these two bytes until the next call and output them then. Obviously, the
-- behaviour of Zlib is subject to change, so we build in some checks on what is
-- happening, as well as check on the content of the two header bytes, in case any
-- future changes to Zlib or Zlib_Ada defaults cause a change from the assumed
-- behaviour. The procedure is generic in order to permit the state information and
-- the file handle to be declared in the code that sets up the Zlib compressor.
-- The three states in the following types correspond to an initial state before the
-- first call, the first call (which should pass the two header bytes) and all later
-- calls, when the default action is taken.
type Zlib_Header_Output_Status is (Not_Yet_Seen, Cached, Output);
subtype Zlib_Header is Stream_Element_Array(1 .. 2);
generic
F : in out File_Type;
Cache : in out Zlib_Header;
Status : in out Zlib_Header_Output_Status;
procedure Write_Compressed_IDAT_Data(Data : in Stream_Element_Array);
procedure Write_Compressed_IDAT_Data(Data : in Stream_Element_Array) is
begin
-- It would not be harmful to output a zero length IDAT chunk, but there is
-- no point in doing so. Versions of Zlib_Ada prior to 1.3 passed zero length
-- data, and the assertion that follows is just a check that this does not
-- occur, as it simplifies the rest of the procedure.
pragma Assert(Data'Length /= 0);
case Status is
when Not_Yet_Seen => -- This must be the first call. It is possible that only
-- one byte has been passed in which case we have a big
-- problem, so we check for this with an assertion.
pragma Assert(Data'Length > 1);
-- Otherwise, we can handle two or more bytes. If there are
-- only two, we cache the two bytes until the next call,
-- if there are more than two, we output an IDAT chunk.
-- Obviously, if Zlib passes three bytes, this results in
-- stupid behaviour, but it is likely that 'more than two'
-- will, in practice, be a large block of data.
Cache := Data(Data'First .. Stream_Element_Offset'Succ(Data'First));
-- Check that the two bytes are valid as a Zlib header in a
-- PNG file. If not, something in the defaults or parameters
-- of Zlib or Zlib_Ada must have changed and PNG_IO needs to
-- be modified to suit.
pragma Assert(Valid_Zlib_Header(Cache(1), Cache(2)));
if Data'Length = 2 then -- This is the expected behaviour.
Status := Cached; -- Output the two bytes on the next call.
else
-- This is plausible behaviour, but not what Zlib does at
-- present.
Write_Chunk(F, IDAT, Data); -- Output a chunk now, and note
Status := Output; -- that the header has been output.
end if;
when Cached => -- Prepend the two cached bytes to the data passed on
-- this, the second call, and output an IDAT chunk.
Write_Chunk(F, IDAT, Cache & Data);
Status := Output;
when Output => Write_Chunk(F, IDAT, Data); -- Normal action: output a chunk.
end case;
end Write_Compressed_IDAT_Data;
procedure Write_Ancillary_Chunks(F : in File_Type;
L : in Chunk_List;
W : Chunk_Position) is
-- Writes any chunks in L whose positioning matches W.
P : Chunk_List := L;
begin
while P /= null loop
if P.Chnk.Where = W then Write_Chunk(F, To_Unsigned_32(P.Chnk.Name), P.Chnk.Data); end if;
P := P.Link;
end loop;
end Write_Ancillary_Chunks;
pragma Inline(Write_Ancillary_Chunks);
procedure Finish_File(F : in out Ada.Streams.Stream_IO.File_Type) is
-- This procedure writes a tEXt chunk and the IEND chunk
-- to the file and closes the file. The tEXt chunk identifies
-- this software as the creator of the PNG file.
begin
Write_Chunk(F, tEXt, To_Stream_Element_Array(Package_Identifier));
Write_Chunk(F, IEND);
Close(F);
end Finish_File;
generic
Bpp : in Stream_Element_Offset := 1; -- The offset between corresponding bytes
-- of adjacent pixels within a scanline, as
-- described in Section 6 of the PNG Specification.
function Adaptive_Filter(Raw, Prior : Stream_Element_Array) return Stream_Element_Array;
function Adaptive_Filter(Raw, Prior : Stream_Element_Array) return Stream_Element_Array is separate;
procedure Write_PNG_Type_0(Filename : in String;
I : in Image_Handle;
X, Y : in Dimension;
Bit_Depth : in Depth := Eight;
Interlace : in Boolean := False;
Ancillary : in Chunk_List := Null_Chunk_List;
Level : in Compression_Level := Default_Compression)
is separate;
procedure Write_PNG_Type_2(Filename : in String;
I : in Image_Handle;
X, Y : in Dimension;
Bit_Depth : in Depth_8_16 := Eight;
Interlace : in Boolean := False;
Ancillary : in Chunk_List := Null_Chunk_List;
Level : in Compression_Level := Default_Compression)
is separate;
procedure Write_PNG_Type_3(Filename : in String;
P : in Palette_Handle;
I : in Image_Handle;
X, Y : in Dimension;
Interlace : in Boolean := False;
Ancillary : in Chunk_List := Null_Chunk_List;
Level : in Compression_Level := Default_Compression)
is separate;
procedure Write_PNG_Type_4(Filename : in String;
I : in Image_Handle;
X, Y : in Dimension;
Bit_Depth : in Depth_8_16 := Eight;
Interlace : in Boolean := False;
Ancillary : in Chunk_List := Null_Chunk_List;
Level : in Compression_Level := Default_Compression)
is separate;
procedure Write_PNG_Type_6(Filename : in String;
I : in Image_Handle;
X, Y : in Dimension;
Bit_Depth : in Depth_8_16 := Eight;
Interlace : in Boolean := False;
Ancillary : in Chunk_List := Null_Chunk_List;
Level : in Compression_Level := Default_Compression)
is separate;
begin
-- Verify the integrity of the chunk type codes.
if To_Chunk_Name(IHDR) /= "IHDR"
or To_Chunk_Name(PLTE) /= "PLTE"
or To_Chunk_Name(IDAT) /= "IDAT"
or To_Chunk_Name(IEND) /= "IEND"
or To_Chunk_Name(cHRM) /= "cHRM"
or To_Chunk_Name(gAMA) /= "gAMA"
or To_Chunk_Name(sRGB) /= "sRGB"
or To_Chunk_Name(pHYs) /= "pHYs"
or To_Chunk_Name(tEXt) /= "tEXt"
or To_Chunk_Name(zTXt) /= "zTXt"
or To_Chunk_Name(tRNS) /= "tRNS"
or To_Chunk_Name(iCCP) /= "iCCP"
or To_Chunk_Name(iTXT) /= "iTXt"
or To_Chunk_Name(bKGD) /= "bKGD"
or To_Chunk_Name(sBIT) /= "sBIT"
or To_Chunk_Name(sPLT) /= "sPLT"
or To_Chunk_Name(hIST) /= "hIST"
or To_Chunk_Name(tIME) /= "tIME" then
Raise_Exception(Program_Error'Identity,
"Internal verification error in chunk codes.");
end if;
end PNG_IO;
|