PC World Komputer 1998 April A/Pcwk4a98.iso/PROGRAM/PASCAL/DUMPING/DUMPING.PAS

Pascal/Delphi Source File | 1995-03-26 | 34KB | 980 lines

Program  DumPing ;

{
   Copyright (c) 1995 by Oliver Fromme  --  All Rights Reserved

   Address:  Oliver Fromme, Leibnizstr. 18-61, 38678 Clausthal, Germany
   Internet:  [e-mail]
   WWW:  http://www.tu-clausthal.de/~inof/

   Freely distributable, freely usable.
   The original copyright notice may not be modified or omitted.
}

{$A+,B-,D+,E-,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 16384,0,655360}

Uses  Dos,Strings,AltCrt2,CRC32,Adler32,Inflate ;

Const  ReadBuffSize = 65528 ;

Type  tReadBuff  = Array [0..Pred(ReadBuffSize)] Of Byte ;
      pReadBuff  = ^tReadBuff ;

Var  PNGHead : Record {see the PNG spec, draft #9}
                  Width,Height  : LongInt ;
                  BitsPerSample : Byte ;
                  ColorType     : Byte ;
                  CM,Filter,IL  : Byte
               End ;

     RunCRC : tCRC ; {see unit CRC32 for details}
     RunAdl : tAdler ; {see unit Adler32 for details}

     ChunkHead : Record
                    Length : LongInt ;
                    Name   : Array [0..3] Of Char
                 End ;

     inname : PathStr ;
     infile : File ;

     LineSize      : LongInt ; {number of bytes in one row incl. filter byte}
     CurrentOffset : LongInt ; {byte position in current row}
     DecompBytes   : LongInt ; {counts decompressed bytes}
     BytesNeeded   : LongInt ; {bytes actually decompressed, should be = DecompBytes}
     NumLines      : LongInt ; {number of scanlines = number of filter bytes}
     OutputRow     : pReadBuff ;
     {Rows larger than 64K are supported, but only the first 64K
      are stored.  Actually we need only the filter type byte.}

     FilterCount : Array [0..5] Of LongInt ;
     PaletteSize : Word ;
     CurrentPass : Byte ; {Adam7 pass, 0..6}

Procedure  Help ;
   Begin
      WriteLn ;
      WriteLn ('DUMPING v0.4  26-Mar-1995') ;
      WriteLn ('Usage:  ',GetName(ParamStr(0)),' <filename[.PNG]>') ;
      WriteLn ('Purpose:  Verifies the given PNG file and dumps its content to the') ;
      WriteLn ('          screen.  Complies with the PNG specification, draft #9.') ;
      Halt
   End {Help} ;

Procedure  Die (Const msg : String) ;
   Begin
      WriteLn ('*** ',msg) ;
      If IsOpenFile(infile) Then
         Close (infile) ;
      Halt (20)
   End {Die} ;

Procedure  Error (Const msg : String) ;
   Const  Always : Boolean = False ;
   Var  c : Char ;
   Begin
      WriteLn ('!!! ',msg) ;
      If Always Then
         Exit ;
      Write ('Try to continue [Y(es)/n(o)/a(lways)]? ') ;
      Repeat
         c := ReadKey ;
         If c=#0 Then
            If ReadKey=#0 Then
      Until UpCase(c) In ['Y','N','A',#13,#27] ;
      If UpCase(c) In ['N',#27] Then
         Die ('Halted.')
      Else Begin
         Write (#13,EmptyString:39,#13) ;
         If UpCase(c)='A' Then
            Always := True
      End
   End {Error} ;

Procedure  CheckIO ;
   Var  iores : Integer ;
   Begin
      iores := IOResult ;
      If iores<>0 Then
         If iores=100 Then
            Die ('Premature end of file.')
         Else
            Die ('I/O error #'+IntStr(iores)+' reading from input file.')
   End {CheckIO} ;

{Some read buffer routines for faster access
 on devices with slow response time.}

Var  ReadBuff    : pReadBuff ;
     rbpos,rbend : Word ;

Procedure  ResetReadBuffer ;
   Begin
      rbpos := ReadBuffSize ;
      rbend := ReadBuffSize
   End {ResetReadBuffer} ;

Procedure  BufferedRead (Var desti ; c : Word) ;
   Var  ec,r : Word ;
   Begin
      If rbpos+LongInt(c)>LongInt(ReadBuffSize) Then Begin
         r := ReadBuffSize-rbpos ;
         If rbpos<ReadBuffSize Then
            Move (ReadBuff^[rbpos],ReadBuff^,r) ;
         BlockRead (infile,ReadBuff^[r],rbpos,ec) ;
         If ec<rbpos Then
            rbend := r+ec ;
         rbpos := 0
      End ;
      Move (ReadBuff^[rbpos],desti,c) ;
      If rbpos+c>rbend Then
         InOutRes := 100
      Else
         Inc (rbpos,c)
   End {BufferedRead} ;

Procedure  ReadCheck (Var desti ; c : Word) ;
   Begin
      BufferedRead (desti,c) ;
      CheckIO ;
      Dec (ChunkHead.Length,c) ;
      UpdateCRC32 (RunCRC,desti,c)
   End {ReadCheck} ;

Procedure  BufferSkipBack (c : LongInt) ;
   Begin
      If rbpos>=c Then
         Dec (rbpos,c)
      Else Begin
         ResetReadBuffer ;
         Seek (infile,FilePos(infile)-c)
      End
   End {BufferSkipBack} ;

Function  MyHeapErrorFunc (Size: Word) : Integer ; Far ;
   Begin
      If Size=0 Then
         MyHeapErrorFUnc := 2 {success}
      Else
         MyHeapErrorFunc := 1 {return NIL}
   End {MyHeapErrorFunc} ;

{Swap a 32 bit variable (MSB<->LSB).}

Procedure  Swap32 (Var LongVar : LongInt) ; Assembler ;
   Asm
                les     si,LongVar
                mov     ax,es:[si]
                mov     dx,es:[si+2]
                xchg    al,dh
                xchg    ah,dl
                mov     es:[si],ax
                mov     es:[si+2],dx
   End {Swap32} ;

{Swap a 16 bit variable (MSB<->LSB).}

Procedure  Swap16 (Var WordVar : Word) ; Assembler ;
   Asm
                les     si,WordVar
                mov     ax,es:[si]
                xchg    al,ah
                mov     es:[si],ax
   End {Swap16} ;

Procedure  ReadChunkHead ;
   Begin
      BufferedRead (ChunkHead,SizeOf(ChunkHead)) ;
      CheckIO ;
      With ChunkHead Do Begin
         Swap32 (Length) ;
         InitCRC32 (RunCRC) ;
         UpdateCRC32 (RunCRC,Name,4) ;
         WriteLn ('"',Copy(Name,1,4),'"',Length:7,' bytes')
      End
   End {ReadChunkHead} ;

{Skip to the end of the current chunk and check the CRC.}

Procedure  SkipChunk ;
   Var  CheckCRC : tCRC ;
        b : Byte ;
   Begin
      With ChunkHead Do
         If Length<0 Then Begin
            BufferSkipBack (-Length) ;
            CheckIO
         End
         Else
            While Length>0 Do
               ReadCheck (b,1) ;
      BufferedRead (CheckCRC,4) ;
      CheckIO ;
      Swap32 (CheckCRC) ;
      If FinalCRC32(RunCRC)<>CheckCRC Then
         Error ('Chunk CRC fails.')
      Else
         WriteLn ('   Chunk CRC ok.')
   End {SkipChunk} ;

{Callback for inflate:  feed an input byte to inflate.}

Function  PNG_ReadByte : Byte ; Far ;
   Var  CheckCRC : tCRC ;
        b : Byte ;
   Begin
      While ChunkHead.Length=0 Do Begin
         SkipChunk ;
         ReadChunkHead ;
         If ChunkHead.Name<>'IDAT' Then Begin
            Error ('IDAT chunk expected (compressed stream is not complete yet).') ;
            WriteLn ('   Assume that this is actually an IDAT chunk.')
         End
      End ;
      ReadCheck (b,1) ;
      PNG_ReadByte := b
   End {PNG_ReadByte} ;

{Apply a filter to a single row of pixels.}

Procedure  ApplyFilter ;
   Var  f : Byte ;
   Begin {ApplyFilter}
      f := OutputRow^[0] ;
      {Since this is only a checker, there is no filter code.
       Instead, the filter type frequencies are computed.}
      If f In [0..4] Then
         Inc (FilterCount[f])
      Else
         Inc (FilterCount[5]) {Illegal filter type}
   End {ApplyFilter} ;

Function  GetLineSize (PixelWidth : LongInt) : LongInt ;
   Begin
      With PNGHead Do
         Case ColorType Of
            0 : GetLineSize := (BitsPerSample*PixelWidth+7) Shr 3 +1 ;
            2 : GetLineSize := (BitsPerSample Shr 3)*3*PixelWidth +1 ;
            3 : GetLineSize := (BitsPerSample*PixelWidth+7) Shr 3 +1 ;
            4 : GetLineSize := (BitsPerSample Shr 2)*PixelWidth +1 ;
            6 : GetLineSize := (BitsPerSample Shr 1)*PixelWidth +1
         Else
            GetLineSize := PixelWidth Shl 3 +1
            {should be pretty save if user wants to ignore error}
         End
   End {GetLineSize} ;

{Tables for Adam7 interlacing.}

Const  Adam7_StartRow : Array [0..6] Of Byte
                      = (0,0,4,0,2,0,1) ;
       Adam7_StartCol : Array [0..6] Of Byte
                      = (0,4,0,2,0,1,0) ;
       Adam7_IncrmRow : Array [0..6] Of Byte
                      = (8,8,8,4,4,2,2) ;
       Adam7_IncrmCol : Array [0..6] Of Byte
                      = (8,8,4,4,2,2,1) ;

Var  CurY : LongInt ;

{Number of pixels/row in current pass}

Function  PassWidth : LongInt ;
   Begin
      PassWidth :=
         (PNGHead.Width+Adam7_IncrmCol[CurrentPass]-1-Adam7_StartCol[CurrentPass])
         Div Adam7_IncrmCol[CurrentPass]
   End {PassWidth} ;

{Number of rows in current pass}

Function  PassHeight : LongInt ;
   Begin
      PassHeight :=
         (PNGHead.Height+Adam7_IncrmRow[CurrentPass]-1-Adam7_StartRow[CurrentPass])
         Div Adam7_IncrmRow[CurrentPass]
   End {PassHeight} ;

{Callback for inflate:  provides output data from the sliding window.}

Function  PNG_Flush (w : Word) : Integer ; Far ;
   Var  CopyOffset,CopyCount,BytesPerLine : Word ;
   Begin
      PNG_Flush := 0 ;
      CopyOffset := 0 ;
      Inc (DecompBytes,w) ;
      UpdateAdler32 (RunAdl,slide^,w) ;
      If CurrentPass>6 Then
         Exit ; {Process_IDAT detects this}
      While w>0 Do Begin
         If PNGHead.IL=1 Then Begin {interlaced}
            {Skip empty passes}
            While ((PassWidth=0) Or (PassHeight=0)) And (CurrentPass<7) Do
               Inc (CurrentPass) ;
            If CurrentPass>6 Then
               Exit ;
            BytesPerLine := GetLineSize(PassWidth)
         End
         Else {non-interlaced}
            BytesPerLine := LineSize ;
         If w>BytesPerLine-CurrentOffset Then
            CopyCount := BytesPerLine-CurrentOffset
         Else
            CopyCount := w ;
         If CurrentOffset+CopyCount<=65528 Then
            Move (slide^[CopyOffset],OutputRow^[CurrentOffset],CopyCount) ;
         Dec (w,CopyCount) ;
         Inc (CopyOffset,CopyCount) ;
         Inc (CurrentOffset,CopyCount) ;
         If CurrentOffset>=BytesPerLine Then Begin {next row}
            ApplyFilter ;
            CurrentOffset := 0 ;
            If PNGHead.IL=1 Then Begin {interlaced}
               Inc (CurY,Adam7_IncrmRow[CurrentPass]) ;
               If CurY>=PNGHead.Height Then Begin
                  Inc (CurrentPass) ;
                  If CurrentPass>6 Then
                     Exit ;
                  CurY := Adam7_StartRow[CurrentPass]
               End
            End
            Else Begin {non-interlaced}
               Inc (CurY) ;
               If CurY>=PNGHead.Height Then
                  Exit
            End
         End
      End
   End {PNG_Flush} ;

Procedure  Process_IHDR ; Far ; Forward ;
Procedure  Process_PLTE ; Far ; Forward ;
Procedure  Process_IDAT ; Far ; Forward ;
Procedure  Process_IEND ; Far ; Forward ;
Procedure  Process_GAMA ; Far ; Forward ;
Procedure  Process_SBIT ; Far ; Forward ;
Procedure  Process_CHRM ; Far ; Forward ;
Procedure  Process_TRNS ; Far ; Forward ;
Procedure  Process_BKGD ; Far ; Forward ;
Procedure  Process_HIST ; Far ; Forward ;
Procedure  Process_TEXT ; Far ; Forward ;
Procedure  Process_ZTXT ; Far ; Forward ;
Procedure  Process_PHYS ; Far ; Forward ;
Procedure  Process_OFFS ; Far ; Forward ;
Procedure  Process_TIME ; Far ; Forward ;

Const  NumChunks = 15 ;
       Chunks : Array [1..NumChunks] Of
                   Record
                      Name    : Array [0..3] Of Char ;
                      Process : Procedure ;
                      HaveIt  : Boolean {True = chunk has appeared}
                   End
              = ((Name: 'IHDR'; Process: Process_IHDR; HaveIt: False),
                 (Name: 'PLTE'; Process: Process_PLTE; HaveIt: False),
                 (Name: 'IDAT'; Process: Process_IDAT; HaveIt: False),
                 (Name: 'IEND'; Process: Process_IEND; HaveIt: False),
                 (Name: 'gAMA'; Process: Process_GAMA; HaveIt: False),
                 (Name: 'sBIT'; Process: Process_SBIT; HaveIt: False),
                 (Name: 'cHRM'; Process: Process_CHRM; HaveIt: False),
                 (Name: 'tRNS'; Process: Process_TRNS; HaveIt: False),
                 (Name: 'bKGD'; Process: Process_BKGD; HaveIt: False),
                 (Name: 'hIST'; Process: Process_HIST; HaveIt: False),
                 (Name: 'tEXt'; Process: Process_TEXT; HaveIt: False),
                 (Name: 'zTXt'; Process: Process_ZTXT; HaveIt: False),
                 (Name: 'pHYs'; Process: Process_PHYS; HaveIt: False),
                 (Name: 'oFFs'; Process: Process_OFFS; HaveIt: False),
                 (Name: 'tIME'; Process: Process_TIME; HaveIt: False)) ;

Function  FindChunk (c : String) : Integer ;
   Var  i : Integer ;
   Begin
      FindChunk := -1 ;
      For i:=1 To NumChunks Do
         If c=Chunks[i].Name Then Begin
            FindChunk := i ;
            Break
         End
   End {FindChunk} ;

Function  CheckLength (l : LongInt) : LongInt ; {returns actual length}
   Begin
      If ChunkHead.Length<>l Then
         Error ('Illegal length of '+ChunkHead.Name+' chunk, must be '+
                LongStr(l)+' bytes.') ;
      CheckLength := ChunkHead.Length
   End {CheckLength} ;

Procedure  CheckMulti ;
   Begin
      If Chunks[FindChunk(ChunkHead.Name)].HaveIt Then
         Error ('This chunk may not appear more than once.')
   End {CheckMulti} ;

Procedure  Process_IHDR ;
   Type  ByteSet = Set Of Byte ;
   Var  w : Word ;

   Procedure  CheckTypeDepth (allowed : ByteSet) ;
      Begin {CheckTypeDepth}
         If Not (PNGHead.BitsPerSample In allowed) Then
            Error ('Illegal color type / bit depth combination.')
      End {CheckTypeDepth} ;

   Begin {Process_IHDR}
      CheckMulti ;
      CheckLength (SizeOf(PNGHead)) ;
      FillChar (PNGHead,SizeOf(PNGHead),0) ;
      ReadCheck (PNGHead,SizeOf(PNGHead)) ;
      With PNGHead Do Begin
         Swap32 (Width) ;
         Swap32 (Height) ;
         WriteLn ('   Width: ',Width:5) ;
         WriteLn ('   Height:',Height:5) ;
         WriteLn ('   Bit depth: ',BitsPerSample,' (max. ',
                  LongInt(1) Shl BitsPerSample,' values/sample)') ;
         If Not (BitsPerSample In [1,2,4,8,16]) Then
            Error ('Illegal bit depth.') ;
         Write ('   Color type: ',ColorType,' (') ;
         Case ColorType Of
            0 : Begin
                   WriteLn ('greyscale)') ;
                   CheckTypeDepth ([1,2,4,8,16])
                End ;
            2 : Begin
                   WriteLn ('RGB)') ;
                   CheckTypeDepth ([8,16])
                End ;
            3 : Begin
                   WriteLn ('color mapped)') ;
                   CheckTypeDepth ([1,2,4,8])
               End ;
            4 : Begin
                   WriteLn ('greyscale+alpha)') ;
                   CheckTypeDepth ([8,16])
                End ;
            6 : Begin
                   WriteLn ('RGB+alpha)') ;
                   CheckTypeDepth ([8,16])
                End
         Else
            WriteLn ('unknown)') ;
            Error ('Illegal color type.')
         End ;
         LineSize := GetLineSize(Width) ;
         Write ('   Compression method: ',CM,' (') ;
         If CM=0 Then
            WriteLn ('deflate/32K)')
         Else Begin
            WriteLn ('unknown)') ;
            Error ('Illegal compression method.')
         End ;
         Write ('   Filter type: ',Filter,' (') ;
         If Filter=0 Then
            WriteLn ('adaptive/5)')
         Else Begin
            WriteLn ('unknown)') ;
            Error ('Illegal filter type.')
         End ;
         Write ('   Interlace type: ',IL,' (') ;
         Case IL Of
            0 : WriteLn ('none)') ;
            1 : WriteLn ('Adam7)')
         Else
            WriteLn ('unknown)') ;
            Error ('Illegal interlace type.')
         End
      End ;
      If LineSize>65528 Then
         w := 65528
      Else
         w := LineSize ;
      GetMem (OutputRow,w) ;
      If OutputRow=NIL Then
         Die ('Not enough memory for output row ('+WordStr(w)+' bytes).') ;
      SkipChunk
   End {Process_IHDR} ;

Procedure  Process_PLTE ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('tRNS')].HaveIt Then
         Error ('Must be before tRNS chunk.') ;
      If Chunks[FindChunk('bKGD')].HaveIt Then
         Error ('Must be before bKGD chunk.') ;
      If Chunks[FindChunk('hIST')].HaveIt Then
         Error ('Must be before hIST chunk.') ;
      With ChunkHead Do Begin
         PaletteSize := Length Div 3 ;
         If Length<3 Then
            Error ('Palette smaller than 3 bytes.')
         Else If Length Mod 3 <>0 Then
            Error ('Palette size not divisible by 3.')
         Else If (PNGHead.ColorType And 1 <>0) And
                 (PaletteSize > Word(1) Shl PNGHead.BitsPerSample) Then
            Error ('Palette larger than bits per index allows.')
         Else If PaletteSize>256 Then
            Error ('Palette contains more than 256 entries.')
         Else
            WriteLn ('   ',PaletteSize,' colors defined.')
      End ;
      SkipChunk
   End {Process_PLTE} ;

Procedure  Process_IDAT ;
   Var  AdlerCheck : LongInt ;
        Result : Integer ;
        w : Word ;
   Begin
      If Chunks[FindChunk(ChunkHead.Name)].HaveIt Then Begin
         Error ('Image is complete, no more IDAT chunks allowed.') ;
         SkipChunk ;
         Exit
      End ;
      If (PNGHead.ColorType=3) And Not Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('PLTE chunk must precede IDAT for colormapped images.') ;
      w := PNG_ReadByte ;
      w := (w Shl 8) Or PNG_ReadByte ;
      WriteLn ('   CMF/FLG: 0x',Hex4(w)) ;
      If w Mod 31 <>0 Then
         Error ('CMF/FLG mod 31 check fails.') ;
      If Hi(w) And $f<>8 Then
         Error ('CMF: illegal compression method, must be 8.')
      Else Begin
         If Hi(w) Shr 4>7 Then
            Error ('CMF: unsupported sliding window size, must be <=7 (32K).') ;
         Case Lo(w) Shr 6 Of
            0 : WriteLn ('   fastest compression') ;
            1 : WriteLn ('   fast compression') ;
            2 : WriteLn ('   default compression') ;
            3 : WriteLn ('   maximum compression')
         End
      End ;
      If w And 32 <>0 Then
         Error ('Bit 5 (reserved) in FLG is set.') ;
      InitAdler32 (RunAdl) ;
      DecompBytes := 0 ;
      With PNGHead Do
         If IL=1 Then Begin {interlaced}
            BytesNeeded := 0 ;
            NumLines := 0 ;
            For CurrentPass:=0 To 6 Do Begin
               Inc (BytesNeeded,GetLineSize(PassWidth)*PassHeight) ;
               Inc (NumLines,PassHeight)
            End
         End
         Else Begin {non-interlaced}
            BytesNeeded := LineSize*Height ;
            NumLines := Height
         End ;
      CurrentOffset := 0 ;
      CurrentPass := 0 ;
      CurY := 0 ;
      InflateRead := PNG_ReadByte ;
      InflateFlush := PNG_Flush ;
      Result := InflateRun ;
      If Result<>0 Then
         Error ('Inflate returns error code '+IntStr(Result)+'.') ;
      WriteLn ('   ',DecompBytes,' bytes decompressed.') ;
      If DecompBytes<>BytesNeeded Then
         Error (LongStr(BytesNeeded)+' bytes expected.') ;
      WriteLn ('   Reading Adler32 checksum...') ;
      For w:=1 To 4 Do
         AdlerCheck := (AdlerCheck Shl 8) Or PNG_ReadByte ;
      If FinalAdler32(RunAdl)<>AdlerCheck Then Begin
         WriteLn ('   Adler32, file: 0x',Hex8(AdlerCheck),', computed: 0x',
                  Hex8(FinalAdler32(RunAdl))) ;
         Error ('Adler32 check on uncompressed data fails.')
      End
      Else
         WriteLn ('   Adler32 check ok.') ;
      If ChunkHead.Length<0 Then
         Error ('Too few bytes in IDAT chunks ('+
                LongStr(-ChunkHead.Length)+' bytes missing).') ;
      If ChunkHead.Length>0 Then
         Error ('Too many bytes in IDAT chunks ('+
                 LongStr(ChunkHead.Length)+' bytes remaining).') ;
      SkipChunk
   End {Process_IDATs} ;

Procedure  Process_IEND ;
   Begin
      CheckLength (0) ;
      SkipChunk
   End {Process_IEND} ;

Procedure  Process_GAMA ;
   Var  gamma : LongInt ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be before PLTE chunk.') ;
      If CheckLength(4)>=4 Then Begin
         ReadCheck (gamma,4) ;
         Swap32 (gamma) ;
         WriteLn ('   Image gamma is ',gamma/100000:4:2,'.')
      End ;
      SkipChunk
   End {Process_GAMA} ;

Procedure  Process_SBIT ;
   Var  w : Word ;
        bits : Byte ;
        Descript : String[4] ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be before PLTE chunk.') ;
      Case PNGHead.ColorType Of
         0 : Begin
                CheckLength (1) ;
                Descript := 'G'
             End ;
         2,3 : Begin
                  CheckLength (3) ;
                  Descript := 'RGB'
               End ;
         4 : Begin
                CheckLength (2) ;
                Descript := 'GA'
             End ;
         6 : Begin
                CheckLength (4) ;
                Descript := 'RGBA'
             End
      End ;
      For w:=1 To Length(Descript) Do Begin
         If ChunkHead.Length<=0 Then
            Break ;
         ReadCheck (bits,1) ;
         WriteLn ('   Significant bits (',Descript[w],'):',bits:3)
      End ;
      SkipChunk
   End {Process_SBIT} ;

Procedure  Process_CHRM ;
   Const  ChrmName : Array [0..7] Of PChar
                   = ('White Point X','White Point Y','  Red X','  Red Y',
                      'Green X','Green Y',' Blue X',' Blue Y') ;
   Var  value : LongInt ;
        w : Word ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be before PLTE chunk.') ;
      CheckLength (32) ;
      For w:=0 To 7 Do Begin
         If ChunkHead.Length<4 Then
            Break ;
         ReadCheck (value,4) ;
         Swap32 (value) ;
         WriteLn ('   ',ChrmName[w],': ',value/100000:4:2,'.')
      End ;
      SkipChunk
   End {Process_CHRM} ;

Procedure  Process_TRNS ;
   Const  SDesc : Array [0..2] Of Char = 'RGB' ;
   Var  trans : Array [0..2] Of Word ;
        w : Word ;
        b : Byte ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If (PNGHead.ColorType=3) And Not Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be after PLTE chunk.') ;
      If PNGHead.ColorType In [4,6] Then
         Error ('tRNS chunk not allowed for full alpha images.') ;
      Case PNGHead.ColorType Of
         3 : Begin
                If ChunkHead.Length>PaletteSize Then
                   Error ('tRNS chunk contains more entries than palette.') ;
                For w:=0 To PaletteSize Do Begin
                   If ChunkHead.Length<=0 Then Begin
                      If w And 15 <>0 Then
                         WriteLn ;
                      Break ;
                   End ;
                   ReadCheck (b,1) ;
                   If w And 15 =0 Then
                      Write ('   ',b:3)
                   Else
                      Write (',',b:3) ;
                   If (w And 15 =15) Or (w=PaletteSize) Then
                      WriteLn
                End
             End ;
         0,4 : If CheckLength(2)>=2 Then Begin
                  ReadCheck (trans[0],2) ;
                  Swap16 (trans[0]) ;
                  WriteLn ('   Transparent grey level: ',trans[0]) ;
                  If trans[0]>=LongInt(1) Shl PNGHead.BitsPerSample Then
                     Error ('tRNS grey level exceeds maximum value.')
               End ;
         2,6 : If CheckLength(6)>=6 Then Begin
                  ReadCheck (trans,6) ;
                  For w:=0 To 2 Do Begin
                     Swap16 (trans[w]) ;
                     WriteLn ('   Transparent level (',SDesc[w],'): ',trans[w]) ;
                     If trans[w]>=LongInt(1) Shl PNGHead.BitsPerSample Then
                        Error ('tRNS level exceeds maximum value.')
                  End
               End
      End ;
      SkipChunk
   End {Process_TRNS} ;

Procedure  Process_BKGD ;
   Const  SDesc : Array [0..2] Of Char = 'RGB' ;
   Var  back : Array [0..2] Of Word ;
        w : Word ;
        b : Byte ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If (PNGHead.ColorType=3) And Not Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be after PLTE chunk.') ;
      Case PNGHead.ColorType Of
         3 : If CheckLength(1)>=1 Then Begin
                ReadCheck (b,1) ;
                WriteLn ('   Background color index: ',b) ;
                If b>=PaletteSize Then
                   Error ('bKGD index exceeds number of palette entries.')
             End ;
         0,4 : If CheckLength(2)>=2 Then Begin
                  ReadCheck (back[0],2) ;
                  Swap16 (back[0]) ;
                  WriteLn ('   Background grey level: ',back[0]) ;
                  If back[0]>=LongInt(1) Shl PNGHead.BitsPerSample Then
                     Error ('bKGD grey level exceeds maximum value.')
               End ;
         2,6 : If CheckLength(6)>=6 Then Begin
                  ReadCheck (back,6) ;
                  For w:=0 To 2 Do Begin
                     Swap16 (back[w]) ;
                     WriteLn ('   Background color (',SDesc[w],'): ',back[w]) ;
                     If back[w]>=LongInt(1) Shl PNGHead.BitsPerSample Then
                        Error ('bKGD color exceeds maximum value.')
                  End
               End
      End ;
      SkipChunk
   End {Process_BKGD} ;

Procedure  Process_HIST ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If (PNGHead.ColorType=3) And Not Chunks[FindChunk('PLTE')].HaveIt Then
         Error ('Must be after PLTE chunk.') ;
      CheckLength (PaletteSize Shl 1) ;
      SkipChunk
   End {Process_HIST} ;

Procedure  Process_TEXT ;
   Begin
      SkipChunk
   End {Process_TEXT} ;

Procedure  Process_ZTXT ;
   Begin
      SkipChunk
   End {Process_ZTXT} ;

Procedure  Process_PHYS ;
   Var  PhysData : Record
                      perx,pery : LongInt ;
                      unitspec  : Byte
                   End ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If CheckLength(SizeOf(PhysData))>=SizeOf(PhysData) Then Begin
         ReadCheck (PhysData,SizeOf(PhysData)) ;
         With PhysData Do Begin
            Swap32 (perx) ;
            Swap32 (pery) ;
            If unitspec>1 Then
               Error ('Unknown unit specifier '+WordStr(unitspec)+'.') ;
            If unitspec=1 Then Begin
               WriteLn ('   X:',perx/100:7:2,' dpcm =',(perx/100)*2.54:7:2,' dpi') ;
               WriteLn ('   Y:',pery/100:7:2,' dpcm =',(pery/100)*2.54:7:2,' dpi')
            End
            Else Begin
               WriteLn ('   X: ',perx) ;
               WriteLn ('   Y: ',pery)
            End ;
            WriteLn ('   => X/Y ascpect ratio = ',perx/pery:5:3)
         End
      End ;
      SkipChunk
   End {Process_PHYS} ;

Procedure  Process_OFFS ;
   Var  OffsData : Record
                      ofsx,ofsy : LongInt ;
                      unitspec  : Byte
                   End ;
   Begin
      CheckMulti ;
      If Chunks[FindChunk('IDAT')].HaveIt Then
         Error ('Must be before IDAT chunks.') ;
      If CheckLength(SizeOf(OffsData))>=SizeOf(OffsData) Then Begin
         ReadCheck (OffsData,SizeOf(OffsData)) ;
         With OffsData Do Begin
            Swap32 (ofsx) ;
            Swap32 (ofsy) ;
            If unitspec>1 Then
               Error ('Unknown unit specifier '+WordStr(unitspec)+'.') ;
            Case unitspec Of
               0 : Begin
                      WriteLn ('   X offset: ',ofsx,' pixels') ;
                      WriteLn ('   Y offset: ',ofsy,' pixels')
                   End ;
               1 : Begin
                      WriteLn ('   X offset: ',ofsx/10000:6:3,' cm =',ofsx/25400:6:3,'"') ;
                      WriteLn ('   Y offset: ',ofsy/10000:6:3,' cm =',ofsy/25400:6:3,'"')
                   End
            Else
               WriteLn ('   X offset: ',ofsx) ;
               WriteLn ('   Y offset: ',ofsy)
            End
         End
      End ;
      SkipChunk
   End {Process_OFFS} ;

Procedure  Process_TIME ;
   Const  MonthDesc : Array [0..12] Of String[3]
                    = ('???','Jan','Feb','Mar','Apr','May','Jun',
                       'Jul','Aug','Sep','Oct','Nov','Dec') ;
   Var  TimeData : Record
                      year : Word ;
                      month,day,hour,minute,second : Byte
                   End ;
   Begin
      CheckMulti ;
      If CheckLength(SizeOf(TimeData))>=SizeOf(TimeData) Then Begin
         ReadCheck (TimeData,SizeOf(TimeData)) ;
         With TimeData Do Begin
            Swap16 (year) ;
            If year<100 Then
               Error ('Illegal year ('+WordStr(year)+').') ;
               {could try to fix, e.g.:  Inc (year,1900)}
            If Not (month In [1..12]) Then Begin
               Error ('Illegal month ('+WordStr(month)+').') ;
               month := 0
            End ;
            If Not (day In [1..31]) Then
               Error ('Illegal day ('+WordStr(day)+').') ;
            {We could check for day>29 when month=2 etc., but this
             is already complicated and picky enough.}
            If Not (hour In [0..23]) Then
               Error ('Illegal hour ('+WordStr(hour)+').') ;
            If Not (minute In [0..59]) Then
               Error ('Illegal minute ('+WordStr(minute)+').') ;
            If Not (second In [0..60]) Then
               Error ('Illegal second ('+WordStr(second)+').') ;
            WriteLn ('   Time of last modification: ',day,'-',MonthDesc[month],
                     '-',year,', ',hour,':',Lead0(minute,2),':',Lead0(second,2))
         End
      End ;
      SkipChunk
   End {Process_TIME} ;

Procedure  Main ;
   Const  PNG_Magic : Array [0..7] Of Char
                    = #137'PNG'#13#10#26#10 ;
   Var  BufMag    : Array [0..7] Of Char ;
        First     : Boolean ; {True = first chunk}
        i         : Integer ;
   Begin
      BufferedRead (BufMag,8) ;
      CheckIO ;
      If BufMag<>PNG_Magic Then
         Die ('Not a valid PNG file (PNG magic mismatch in first 8 bytes).') ;
      First := True ;
      With ChunkHead Do
         While Name<>'IEND' Do Begin
            ReadChunkHead ;
            If ChunkHead.Name='IHDR' Then
               Process_IHDR
            Else Begin
               If First Then
                  Error ('First chunk is not IHDR.') ;
               i := FindChunk(ChunkHead.Name) ;
               If i>=0 Then Begin
                  Chunks[i].Process ;
                  Chunks[i].HaveIt := True
               End
               Else Begin
                  If Byte(ChunkHead.Name[0]) And 32 =0 Then
                     Error ('Unknown critical chunk.')
                  Else
                     WriteLn ('   Unknown ancillary chunk.') ;
                  SkipChunk
               End
            End ;
            First := False
         End ;
      If (rbpos<rbend) Or Not EOF(infile) Then
         Error ('File contains data after IEND chunk.')
      Else
         WriteLn ('-EOF-')
   End {Main} ;

Procedure  Init ;
   Begin
      If ParamCount<>1 Then
         Help ;
      inname := ExtPath(FExpand(ParamStr(1)),'PNG') ;
      WriteLn ('Input file: ',inname) ;
      Assign (infile,inname) ;
      Reset (infile,1) ;
      If IOResult<>0 Then
         Die ('Input file not found.') ;
      HeapError := @MyHeapErrorFunc ;
      GetMem (slide,WSIZE) ;
      If slide=NIL Then
         Die ('Not enough memory for sliding window ('+WordStr(WSIZE)+' bytes).') ;
      GetMem (ReadBuff,ReadBuffSize) ;
      If ReadBuff=NIL Then
         Die ('Not enough memory for read buffer ('+WordStr(ReadBuffSize)+' bytes).') ;
      ResetReadBuffer ;
      FillByte (FilterCount,SizeOf(FilterCount),0)
   End {Init} ;

Procedure  Done ;
   Var  w : Word ;
   Const  FilterName : Array [0..5] Of String[9]
                     = ('(none)','(sub)','(up)','(average)',
                        '(paeth)','(illegal)') ;
   Begin
      Close (infile) ;
      WriteLn ('Filter usage statistics:') ;
      For w:=0 To 5 Do Begin
         WriteLn ('Filter #',w,FilterName[w]:10,':',FilterCount[w]:5,
                  (FilterCount[w]*100)/NumLines:7:1,'%') ;
      End ;
      If FilterCount[5]<>0 Then
         Error ('File contains illegal filter types.') ;
      WriteLn ('-Ok-')
   End {Done} ;

Begin
   Init ;
   Main ;
   Done
End.