{ GTImage - Image detection unit BMP, GIF, IFF, JPG, PCX, PNG Created: 04.02.1998 Last Update: 09.02.1998 !! Seems to work out fine !! Copyright (c) 1997, 98 by Philip Helger (philip@dke.univie.ac.at) } {$define extended} {$i aflags.inc} unit GTImage; interface procedure CheckImage; implementation uses Typ, TAusgabe, UString, TArchive; const TrueColor = 16777216; type { Win1 bitmaps } Win1_Header = record id:word; { $00 } Width:word; Height:word; ByteWidth:word; Planes:byte; { 1 } BitsPerPixel:byte; { 1, 4, 8 } end; { Win2-95 bitmaps } BMP_Main_Header = record ID:word; { $4D42 } Size:longint; { b.FSize if compressed - else 0 } Res1:word; { $00 } Res2:word; { $00 } StartOfs:longint; HeaderSize:longint; { Win2=12; Win3=WinNT=40; Win95=108 } end; { if BitsPerPixel = 1, 4 or 8 entries = 1 shl BitsPerPixel or entries = (StartOfs - SizeOf (HeaderWin2_1) - SizeOf (HeaderWin2_2)) / SizeOf (Win2_Palette) } Win3_Pal_Entry = record Blue:byte; Green:byte; Red:byte; end; Win4_Pal_Entry = record Blue:byte; Green:byte; Red:byte; Reserved:byte; { 0 } end; { if BPP = 16 or 32 else Win3_Palette } BMP_Bitfield_Mask = record RedMask:longint; GreenMask:longint; BlueMask:longint; end; { Win2 bitmaps } pWin2_Header = ^Win2_Header; Win2_Header = record Width:integer; Height:integer; Planes:word; { 1 } BitsPerPixel:word; { 1, 4, 8, 24 } end; { Win3 bitmaps } pWin3_Header = ^Win3_Header; Win3_Header = record Width:longint; Height:longint; Planes:word; { 1 } BitsPerPixel:word; { 3.x: 1, 4, 8, 24 } { NT: 1, 4, 8, 16, 24, 32 } Compression:longint; { 3.x: 0, 1, 2 } { NT: 0, 1, 2, 3 if (BPP must be 16 or 32) } SizeOfBMP:longint; { 0 if Compression is 0 } HorizRes:longint; VertRes:longint; ColsUsed:longint; { if ColsUsed = 0 and BitsPerPixel < 16 then -> ColsUsed = 1 shl BitsPerPixel } ColsImportant:longint; { if ColsImportant = 0 then -> ColsImportant = ColsUsed } end; TLongRGBValue = record X, Y, Z:longint; end; TLongRGB = record Red, Green, Blue:longint; end; { NT bitmaps } pWinNT_Header = ^WinNT_Header; WinNT_Header = Win3_Header; { 95 bitmaps } pWin95_Header = ^Win95_Header; Win95_Header = record Width:longint; Height:longint; Planes:word; { 1 } BitsPerPixel:word; { 1, 4, 8, 16, 24, 32 } Compression:longint; { 0, 1, 2, 3 (BPP must be 16 or 32) } SizeOfBMP:longint; { 0 if Compression is 0 } HorizRes:longint; VertRes:longint; ColsUsed:longint; { if ColsUsed = 0 and BitsPerPixel < 16 then -> ColsUsed = 1 shl BitsPerPixel } ColsImportant:longint; { if ColsImportant = 0 then -> ColsImportant = ColsUsed } Mask:TLongRGB; MaskAlpha:longint; CSType:longint; Red:TLongRGBValue; { only used if CSType = 0 } Green:TLongRGBValue; Blue:TLongRGBValue; Gamma:TLongRGB; end; pOS2_Header = ^OS2_Header; OS2_Header = record Width:longint; Height:longint; BitPlanes:word; BitsPerPixel:word; Compression:longint; ImageDataSize:longint; XRes:longint; YRes:longint; ColorsUsed:longint; ColorsImportant:longint; Units:word; Res1:word; Recording:word; Rendering:word; Size1:longint; Size2:longint; ColorEncoding:longint; Identifier:longint; end; TBMP = object bBMP:boolean; Head:BMP_Main_Header; BufLen:word; BufPtr:pointer; procedure Init; procedure Done; function GetVersion:word; function GetWidth:longint; function GetHeight:longint; function GetBPP:word; function GetColors:longint; function GetCompression:longint; function GetVersionStr:ShortStr; end; GIFHeader = record ID:array[1..6] of char; Width:word; Height:word; Flags:byte; end; TGIFLiteKennung = string[7]; TGIF = object H:GIFHeader; procedure init; procedure GetLiteKennung (var k:TGIFLiteKennung); function IsGIF:boolean; function GetColors:word; function IsGIFLite:boolean; function IsInterlaced:boolean; end; IFFHeader = record ID:array[1..4] of char; Size:longint; end; IFF_BMHD = record Width:word; Height:word; Left:word; Top:word; BitPlanes:byte; Masking:byte; Compress:byte; Padding:byte; Transparency:word; XAspectRatio:byte; YAspectRatio:byte; PageWidth:word; PageHeight:word; end; JPGHeader = record ID:word; BPP:byte; Res:byte; Height:word; Width:word; end; pPCXHeader = ^PCXHeader; PCXHeader = record ID:byte; { 0A } Version:byte; Encoding:byte; BitsPerPixel:byte; XMin:word; YMin:word; XMax:word; YMax:word; HRes:word; VRes:word; EGAPal:array [0..47] of byte; Res1:byte; { 00 } NumBitPlanes:byte; BytesPerLine:word; PalType:word; Res2:array [0..57] of byte; { all 00 } end; PNGHeader = record ID:array[1..8] of char; Res1:array[1..8] of byte; Width:longint; Height:longint; ColorDepth:byte; ColorType:byte; Res2:word; Flags:byte; end; PNGBlockHeader = record Following_Bytes:longint; Chunktype:array[1..4] of char; width:longint; height:longint; bit_depth:byte; color_type:byte; compression_type:byte; filter_type:byte; interlace_type:byte; end; RASHeader = record ID:longint; Width:longint; Height:longint; Depth:longint; Length:longint; ImageType:longint; ColormapType:longint; ColormapLength:longint; end; WMFHeader = record ID:longint; Handle:word; Left:integer; Top:integer; Right:integer; Bottom:integer; Inch:word; Reserved:longint; Checksum:word; end; WMFDataHeader = record FileType:word; HeaderSize:word; { in WORDS !! } Version:word; FileSize:longint; NumOfObjects:word; MaxRecordSize:longint; NoPramaters:word; end; WPGHeader = record ID:longint; DataOffset:longint; ProductType:byte; FileType:byte; MajorVersion:byte; MinorVersion:byte; EncryptionKey:word; Reserved:word; end; const BMP_HM_SIZE = SizeOf (BMP_Main_Header); BMP_H1_SIZE = SizeOf (Win1_Header); BMP_H2_SIZE = SizeOf (Win2_Header); BMP_H3_SIZE = SizeOf (Win3_Header); BMP_HNT_SIZE = SizeOf (WinNT_Header); BMP_H95_SIZE = SizeOf (Win95_Header); BMP_PAL3_SIZE = SizeOf (Win3_Pal_Entry); BMP_PAL4_SIZE = SizeOf (Win4_Pal_Entry); BMP_MASK_SIZE = SizeOf (BMP_Bitfield_Mask); GIF_H_SIZE = SizeOf (GIFHeader); IFF_H_SIZE = SizeOf (IFFHeader); JPG_H_SIZE = SizeOf (JPGHeader); PCX_H_SIZE = SizeOf (PCXHeader); PNG_H_SIZE = SizeOf (PNGHeader); RAS_H_SIZE = SizeOf (RASHeader); WMF_H_SIZE = SizeOf (WMFHeader); WPG_H_SIZE = SizeOf (WPGHeader); { for bitmaps } Win1 = 1; Win2 = 2; Win3 = 3; WinNT = 4; Win95 = 5; OS2 = 6; {-------------------------[BMP]-------------------------} procedure TBMP.init; begin b.GetBuf (Head, 1, BMP_HM_SIZE); bBMP := ((Head.ID = $4D42) or { BM } (Head.ID = $4349) { IC } ) and ((Head.HeaderSize = 12) or (Head.HeaderSize = 40) or (Head.HeaderSize = 64) or (Head.HeaderSize = 108)); if (bBMP) then begin BufLen := Head.HeaderSize; getmem (BufPtr, BufLen); b.GetBuf (BufPtr^, BMP_HM_SIZE + 1, BufLen); end; end; procedure TBMP.Done; begin if (bBMP) then freemem (BufPtr, BufLen); end; function TBMP.GetVersion:word; begin case Head.headersize of 12: GetVersion := Win2; 40: if (pWin3_Header (BufPtr)^.Compression = 3) then GetVersion := WinNT else GetVersion := Win3; 64: GetVersion := OS2; 108: GetVersion := Win95; end; end; function TBMP.GetWidth:longint; begin case GetVersion of Win2: GetWidth := pWin2_Header (BufPtr)^.Width; Win3: GetWidth := pWin3_Header (BufPtr)^.Width; WinNT:GetWidth := pWinNT_Header (BufPtr)^.Width; Win95:GetWidth := pWin95_Header (BufPtr)^.Width; OS2 :GetWidth := pOS2_Header (BufPtr)^.Width; end; end; function TBMP.GetHeight:longint; begin case GetVersion of Win2: GetHeight := pWin2_Header (BufPtr)^.Height; Win3: GetHeight := pWin3_Header (BufPtr)^.Height; WinNT:GetHeight := pWinNT_Header (BufPtr)^.Height; Win95:GetHeight := pWin95_Header (BufPtr)^.Height; OS2: GetHeight := pOS2_Header (BufPtr)^.Height; end; end; function TBMP.GetBPP:word; begin case GetVersion of Win2: GetBPP := pWin2_Header (BufPtr)^.BitsPerPixel; Win3: GetBPP := pWin3_Header (BufPtr)^.BitsPerPixel; WinNT:GetBPP := pWinNT_Header (BufPtr)^.BitsPerPixel; Win95:GetBPP := pWin95_Header (BufPtr)^.BitsPerPixel; OS2: GetBPP := pOS2_Header (BufPtr)^.BitsPerPixel; end; end; function TBMP.GetColors:longint; begin GetColors := Exp2 (GetBPP); end; function TBMP.GetCompression:longint; begin case GetVersion of Win2: GetCompression := 0; Win3: GetCompression := pWin3_Header (BufPtr)^.Compression; WinNT:GetCompression := pWinNT_Header (BufPtr)^.Compression; Win95:GetCompression := pWin95_Header (BufPtr)^.Compression; OS2: GetCompression := pOS2_Header (BufPtr)^.Compression; end; end; function TBMP.GetVersionStr:ShortStr; begin case GetVersion of Win2: GetVersionStr := '2 - Windows 2.x / OS/2 1.x'; Win3: GetVersionStr := '3 - Windows 3.x'; WinNT:GetVersionStr := '3 - Windows NT'; Win95:GetVersionStr := '4 - Windows 95'; else GetVersionStr := '3 - OS/2 2.x ??'; end; end; procedure Check_BMP; var p:TBMP; begin p.init; if (p.bBMP) then if WriteHeader (concat ('Bitmap image (type ', p.GetVersionStr, ')')) then begin FinishLine; NoteResolution (p.GetWidth, p.GetHeight, p.GetColors); end; p.Done; end; {-------------------------[GIF]-------------------------} procedure TGIF.init; begin b.GetBuf (H, 1, GIF_H_SIZE); end; procedure TGIF.GetLiteKennung (var k:TGIFLiteKennung); var StartPos:TPos; x:byte; begin StartPos := 13 + 3 * GetColors + 1; while (b.GetByte (StartPos) = 33) do { "!" } begin if (b.GetString (StartPos + 3, 7) = 'GIFLITE') then exit; { repeat inc (StartPos); until b.GetByte (StartPos) = 0; repeat inc (StartPos); until (b.GetByte (StartPos) = 33) or (b.GetByte (StartPos) = 44); } StartPos := b.GetPosOfByte (StartPos, b.BufLen, 0); if StartPos = POSERROR then StartPos := b.BufLen else repeat inc (StartPos); x := b.GetByte (StartPos); until (x = 33) or (x = 44) or (StartPos >= b.BufLen); end; k := b.GetString (StartPos, 7); { Da fehlt was !!! (evtl) } end; function TGIF.IsGIF:boolean; begin IsGIF := (H.ID = 'GIF87a') or (H.ID = 'GIF89a'); end; function TGIF.GetColors:word; begin GetColors := Exp2 ((H.Flags and 7) + 1); { bits 1-3 } end; function TGIF.IsInterlaced:boolean; var StartPos, PalLen:word; x:byte; begin PalLen := 3 * GetColors; StartPos := 13 + PalLen + 1; while (b.GetByte (StartPos) = 33) do { "!" } begin StartPos := b.GetPosOfByte (StartPos, b.BufLen, 0); if StartPos = POSERROR then StartPos := b.BufLen else repeat inc (StartPos); x := b.GetByte (StartPos); until (x = 33) or (x = 44) or (StartPos >= b.BufLen); end; inc (StartPos, 9); IsInterlaced := (b.GetByte (StartPos) and 64 = 64); { if bit 6 is set } end; function TGIF.IsGIFLite:boolean; var k:TGIFLiteKennung; begin GetLiteKennung (k); IsGIFLite := (k = 'GIFLITE'); end; procedure Check_GIF; var p:TGIF; s:ShortStr; begin p.init; if p.IsGIF then if WriteHeader (concat (p.H.ID, ' image ')) then begin if p.IsInterlaced then Appendln (Enbraced ('Interlaced')) else Appendln (Enbraced ('non interlaced')); if (p.IsGIFLite) then Noteln ('Packed with GIFLITE'); NoteResolution (p.H.Width, p.H.Height, p.GetColors); end; end; {-------------------------[IFF]-------------------------} procedure AnalyzeIFF; var f:TFile; H:IFFHeader; p:longint; procedure BMHD; var h:IFF_BMHD; begin f.ReadActBuf (h, SizeOf (h)); Append (concat (i2s (swap (h.Width)), 'x', i2s (swap (h.Height)), STR_SEPERATOR, i2s (Exp2 (h.BitPlanes)), ' colors')); if (h.Compress > 0) then Append (concat (STR_SEPERATOR, ' compressed')); FinishLine; end; procedure CMAP; begin Appendln (concat ('Color table with ', i2s (SwapLong (h.Size) div 3), ' entries')); end; procedure NoteFormat; begin Note (concat (h.ID, ' š ')); { textual data } if (h.ID = '(C) ') then Appendln ('Copyright notice and license') else if (h.ID = 'ANNO') then Appendln ('Annotation or comment') else if (h.ID = 'DOC ') then Appendln ('Document formatting information') else if (h.ID = 'FOOT') then Appendln ('Footer information of a document') else if (h.ID = 'HEAD') then Appendln ('Header information of a document') else if (h.ID = 'PAGE') then Appendln ('Page break indicator') else if (h.ID = 'PARA') then Appendln ('Paragraph formatting information') else if (h.ID = 'PDEF') then Appendln ('Deluxe Print page definition') else if (h.ID = 'TABS') then Appendln ('Tab positions') else if (h.ID = 'TEXT') then Appendln ('Text for a paragraph') else if (h.ID = 'VERS') then Appendln ('File version') else if (h.ID = 'FTXT') then Appendln ('Formatted text') else if (h.ID = 'WORD') then Appendln ('Pro-write word processing') { graphical data } else if (h.ID = 'ACBM') then Appendln ('Amiga Contiguous Bitmap (Microsoft Basic for the Amiga)') else if (h.ID = 'DEEP') then Appendln ('IFF Deep (24-bit color image)') else if (h.ID = 'DR2D') then Appendln ('2D object standard format (vector data)') else if (h.ID = 'FNTR') then Appendln ('Raster font') else if (h.ID = 'FNTV') then Appendln ('Vector font') else if (h.ID = 'ILBM') then Appendln ('InterLeaved Bitmap (interleaved planar bitmap data)') else if (h.ID = 'PBM ') then Appendln ('Portable bitmap') else if (h.ID = 'PICS') then Appendln ('Macintosh picture') else if (h.ID = 'RGB8') then Appendln ('24-bit color image (Impulse)') else if (h.ID = 'RGBN') then Appendln ('12-bit color image (Impulse)') else if (h.ID = 'TDDD') then Appendln ('Turbo3d renderung data (3D objects)') else if (h.ID = 'YUVN') then Appendln ('YUV image data (V-Lab)') { animation data } else if (h.ID = 'ANBM') then Appendln ('Animated bitmap') else if (h.ID = 'ANIM') then Appendln ('Cel animations') else if (h.ID = 'SSA ') then Appendln ('Super smooth animation (ProDAD)') { video data } else if (h.ID = 'VDEO') then Appendln ('Deluxe Video Construction Set video') { sound data } else if (h.ID = '8SVX') then Appendln ('8-bit sampled voice') else if (h.ID = 'AIFF') then Appendln ('Audio interchange file format') else if (h.ID = 'SAMP') then Appendln ('Sampled sound') else if (h.ID = 'UVOX') then Appendln ('Uhuru Sound Software Macintosh voice') { music data } else if (h.ID = 'GSCR') then Appendln ('General use musical score') else if (h.ID = 'SMUS') then Appendln ('Simple musical score') else if (h.ID = 'TRAK') then Appendln ('MIDI music data') else if (h.ID = 'USCR') then Appendln ('Uhuru Sound Software musical score') { rest data } else if (h.ID = 'BMHD') then BMHD else if (h.ID = 'CMAP') then CMAP else if (h.ID = 'BODY') then Appendln ('image data') else Appendln ('unknown type'); end; begin f.init (b.FName, 0); { read global header } f.ReadActBuf (H, IFF_H_SIZE); f.ReadActBuf (H, 4); NoteFormat; IncInsLevel; p := IFF_H_SIZE + 4; repeat if (f.ReadActBuf (H, IFF_H_SIZE) = IFF_H_SIZE) then begin NoteFormat; inc (p, IFF_H_SIZE + SwapLong (h.Size)); f.GotoFilePos (p); end; until (not f.IsOkay); DecInsLevel; f.done; end; procedure Check_IFF; begin if (b.GetString (1, 4) = 'FORM') then if WriteHeader ('IFF file') then begin FinishLine; AnalyzeIFF; end; end; {-------------------------[JPG]-------------------------} procedure Check_JPG; var StartPos:TPos; Colors:longint; StartByte:byte; H:JPGHeader; begin if (b.First.w[1] = $D8FF) then begin if b.First.b[11] = 0 then StartByte := 12 else StartByte := 11; if WriteHeader (concat ('JPG ', GetVersionStr ( b.First.b[StartByte], b.First.b[StartByte + 1]), ' image')) then begin FinishLine; StartPos := b.GetPosOfByte (3, b.BufLen, 192); if (StartPos > POSERROR) then b.GetBuf (H, StartPos, JPG_H_SIZE); Colors := 0; case H.BPP of 11:Colors := 256; 17:Colors := TrueColor; end; NoteResolution (swap (H.Width), swap (H.Height), Colors); end; end; end; {-------------------------[PCX]-------------------------} function IsPCX (p:pPCXHeader):boolean; begin IsPCX := (p^.ID = 10) and { ID } (p^.Res1 = 0); end; procedure Check_PCX; var H:PCXHeader; begin b.GetBuf (H, 1, PCX_H_SIZE); if IsPCX (@H) then if WriteHeader ('ZSoft PCX image') then begin FinishLine; NoteResolution (H.XMax - H.XMin + 1, H.YMax - H.YMin + 1, Exp2 (H.BitsPerPixel * H.NumBitPlanes)); end; end; {-------------------------[PNG]-------------------------} procedure Check_PNG; var s:ShortStr; H:PNGHeader; Colors:longint; begin b.GetBuf (H, 1, PNG_H_SIZE); if (H.ID = '‰PNG'#13#10#26#10) then begin if H.Flags > 0 then s := 'interlaced' else s := 'non interlaced'; if WriteHeader (concat ('PiNG image ', Enbraced (s))) then begin FinishLine; if (H.ColorDepth = 8) and (H.ColorType = 2) then Colors := TrueColor else Colors := Exp2 (H.ColorDepth); NoteResolution (SwapLong (H.Width), SwapLong (H.Height), Colors); end; end; end; {-------------------------[RAS]-------------------------} procedure Check_RAS; var H:RASHeader; begin b.GetBuf (H, 1, RAS_H_SIZE); if (SwapLong (H.ID) = $59A66A95) then if WriteHeader ('Sun Raster image') then begin FinishLine; NoteResolution (SwapLong (H.Width), SwapLong (H.Height), Exp2 (SwapLong (H.Depth))); end; end; {-------------------------[WMF]-------------------------} procedure Check_WMF; var H:WMFHeader; begin b.GetBuf (H, 1, WMF_H_SIZE); if (H.ID = $9AC6CDD7) then if WriteHeader ('Windows Metafile image') then begin FinishLine; IncInsLevel; Noteln (concat ('Coordinates stored: ', i2s (H.Left), '/', i2s (H.Top), ' - ', i2s (H.Right), '/', i2s (H.Bottom))); DecInsLevel; end; end; {-------------------------[WPG]-------------------------} procedure Check_WPG; var H:WPGHeader; begin b.GetBuf (H, 1, WPG_H_SIZE); if (H.ID = $435057FF) and { WPC } (H.DataOffset = $10) and (H.ProductType = $01) and (H.FileType = $16) then if WriteHeader (concat ('Wordperfect Graphics ', GetVersionStr (H.MajorVersion, H.MinorVersion), ' image')) then begin FinishLine; NoteNoResolution; end; end; {-------------------------[XXX]-------------------------} procedure CheckImage; begin if (GetFormatCounter = 0) then Check_BMP; if (GetFormatCounter = 0) then Check_GIF; if (GetFormatCounter = 0) then Check_IFF; if (GetFormatCounter = 0) then Check_JPG; if (GetFormatCounter = 0) then Check_PCX; if (GetFormatCounter = 0) then Check_PNG; if (GetFormatCounter = 0) then Check_RAS; if (GetFormatCounter = 0) then Check_WMF; if (GetFormatCounter = 0) then Check_WPG; end; end.