home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / imd100.zip / IMD.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-31  |  14KB  |  477 lines
  1. {$M 5120,0,655360}
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I-} {disable I/O checking - trap errors by checking IOResult}
  5. {$S- no stack checking code}
  6.  
  7. PROGRAM ImageDirectory;
  8. USES DOS;
  9. CONST
  10.   lf = #13#10;
  11.  
  12. PROCEDURE showhelp (problem : BYTE);
  13. (* If any *foreseen* errors arise, we are sent here to
  14.    give a little help and exit (relatively) peacefully *)
  15. VAR
  16.   message : STRING [50];
  17. BEGIN
  18.   WriteLn ('IMD v1.00 - Free DOS Image Directory utility.');
  19.   WriteLn ('Copyright (c) July 31, 1995, by David Daniel Anderson - Reign Ware.' + lf);
  20.   WriteLn ('Usage:    IMD [file_spec]' + lf);
  21.   WriteLn ('Example:  IMD a:\mariah*.gif' + lf);
  22.   IF problem > 0 THEN BEGIN
  23.     CASE problem OF
  24.       1 : message := 'No files matching specification found.';
  25.       ELSE  message := 'Unanticipated error of unknown type.';
  26.     END;
  27.     WriteLn ('Error:    ' + message);
  28.   END;
  29.   Halt (problem)
  30. END;
  31.  
  32. FUNCTION leadingzero (w : WORD) : STRING;
  33. VAR
  34.   s : STRING;
  35. BEGIN
  36.   Str (w : 0, s);
  37.   IF (Length (s) = 1) THEN
  38.     s := '0' + s;
  39.   leadingzero := s;
  40. END;
  41.  
  42. FUNCTION Comma (li : LONGINT) : STRING;
  43. VAR
  44.   s : STRING [15];
  45.   l : SHORTINT;
  46. BEGIN
  47.   Str (li, s);
  48.   l := (Length (s) - 2);
  49.   WHILE (l > 1) DO BEGIN
  50.     Insert (',', s, l);
  51.     Dec (l, 3);
  52.   END;
  53.   Comma := s;
  54. END;
  55.  
  56. FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
  57. BEGIN
  58.   WHILE (Length (bstr) < len) DO
  59.     bstr := bstr + #32;
  60.   RPad := bstr;
  61. END;
  62.  
  63. PROCEDURE getpath (VAR adjusted_path : STRING);
  64. BEGIN
  65.   IF (ParamStr (1) = '') THEN
  66.     adjusted_path := '*.*'
  67.   ELSE BEGIN
  68.     adjusted_path := ParamStr (1);
  69.     IF (Pos ('.', adjusted_path) = 0) THEN BEGIN
  70.       IF NOT (adjusted_path [Length (adjusted_path) ] IN [':', '\']) THEN
  71.         adjusted_path := adjusted_path + '\';
  72.       adjusted_path := adjusted_path + '*.*';
  73.     END;
  74.   END;
  75. END;
  76.  
  77. PROCEDURE writetime (fdatetime : LONGINT);
  78. VAR
  79.   DateTimeInf : DATETIME;
  80. BEGIN
  81.   UnpackTime (fdatetime, DateTimeInf);
  82.   WITH DateTimeInf DO BEGIN
  83.     Write
  84.     (LeadingZero (Month): 4, '-',
  85.     LeadingZero (Day) , '-',
  86.     Copy (LeadingZero (Year), 3, 2), '  ',
  87.     LeadingZero (Hour), ':',
  88.     LeadingZero (Min), ':',
  89.     LeadingZero (Sec));
  90.   END;
  91. END;
  92.  
  93. FUNCTION GetBMPInfo (CONST FName: STRING): BOOLEAN;
  94. { This procedure takes the name of an existing file as input, and tries
  95.   to write the header contents of the file on screen. }
  96. TYPE
  97.   BMPheader =
  98.   RECORD
  99.     bfType :             WORD;
  100.     bfSize :             LONGINT;
  101.     bfReserved :         LONGINT;     {Moet 0 zijn}
  102.     bfOffBits :          LONGINT;
  103.     biSize :             LONGINT;
  104.     biWidth :            LONGINT;
  105.     biHeight :           LONGINT;
  106.     biPlanes :           WORD;        {Moet 1 zijn}
  107.     biBitCount :         WORD;        {1,4,8,24}
  108.     biCompression :      LONGINT;
  109.     biSizeImage :        LONGINT;     {in bytes}
  110.     biXPelsPerMeter :    LONGINT;
  111.     biYPelsPerMeter :    LONGINT;
  112.     biClrUsed :          LONGINT;
  113.     biClrImportant :     LONGINT;
  114.   END;
  115.  
  116. LABEL
  117.   SkipBMP;
  118.  
  119. VAR
  120.   ImageFile: FILE;
  121.   BitMapHeader : BMPheader;
  122.   Colors : String[4];
  123.   BytesRead : WORD;
  124.   IsBMP : BOOLEAN;
  125.  
  126. BEGIN
  127.   IsBMP := FALSE;
  128.   Assign (ImageFile, FName);
  129.   Reset (ImageFile, 1);
  130.   BlockRead (ImageFile, BitMapHeader, SizeOf (BitMapHeader), BytesRead);
  131.   Close (ImageFile);
  132.   IF (IOResult = 0) AND (BytesRead = SizeOf(BitMapHeader)) THEN
  133.   WITH BitMapHeader DO
  134.   BEGIN
  135.     IF (bfType <> 19778) OR (bfReserved <> 0) OR (biPlanes <> 1) THEN
  136.       Goto SkipBMP;
  137.     CASE (biBitCount) OF
  138.       1 : Colors := '2';
  139.       4 : Colors := '16';
  140.       8 : Colors := '256';
  141.       24: Colors := '16m'; {2^24}
  142.       ELSE
  143.         Goto SkipBMP;
  144.     END;
  145.     IsBMP := TRUE;
  146.     IF biClrUsed <> 0 THEN
  147.       Str (biClrUsed, Colors);
  148.     WriteLn ('wBMP ':10, '   [', biWidth:4, biHeight:5, colors:5, ' ]');
  149.   END;
  150.   SkipBMP:
  151.   GetBMPInfo := IsBMP;
  152. END;
  153.  
  154. PROCEDURE CheckGIFlite (CONST fname: STRING; FPos: LONGINT; OFFSET: WORD);
  155. VAR
  156.   giflite: ARRAY [1..7] OF CHAR;
  157.   blocklabel: ARRAY [1..2] OF CHAR;
  158.   ImageFile: FILE;
  159.   BytesRead : WORD;
  160.  
  161. BEGIN
  162.   Assign (ImageFile, fname);
  163.   Reset (ImageFile, 1);
  164.   FillChar (giflite [1], SizeOf(giflite), #32);
  165.   FillChar (blocklabel [1], SizeOf(blocklabel), #32);
  166.   Seek (ImageFile, FPos + (3 * OFFSET));
  167.   IF (IOResult = 0) THEN
  168.   BEGIN
  169.     BlockRead (ImageFile, blocklabel, SizeOf(blocklabel), BytesRead);
  170.     IF (IOResult = 0) AND (BytesRead = SizeOf(blocklabel)) AND (blocklabel = #33#255) THEN BEGIN
  171.       Seek (ImageFile, FilePos(ImageFile) + 1);
  172.       BlockRead (ImageFile, giflite, SizeOf(giflite), BytesRead);
  173.     END;
  174.   END;
  175.   Close (ImageFile);
  176.   IF (IOResult = 0) AND (BytesRead = SizeOf(giflite)) AND (giflite = 'GIFLITE')
  177.     THEN WriteLn (' (LITE)')
  178.     ELSE WriteLn;
  179. END;
  180.  
  181. FUNCTION GetGIFInfo (CONST FName: STRING): BOOLEAN;
  182. TYPE
  183.   Image_Rec = RECORD
  184.                 i_version : ARRAY [1..6] OF CHAR;
  185.                 i_width,
  186.                 i_height : WORD;
  187.                 i_colors : BYTE;
  188.               END;
  189.  
  190. VAR
  191.   ImageData: Image_Rec;
  192.   ImageFile: FILE;
  193.   rez : WORD;
  194.   FPos: LONGINT;
  195.   BytesRead : WORD;
  196.   IsGIF: BOOLEAN;
  197.  
  198. BEGIN
  199.   IsGIF := FALSE;
  200.   Assign (ImageFile, FName);
  201.   Reset (ImageFile, 1);
  202.   IF (IOResult = 0) THEN
  203.   BEGIN
  204.     BlockRead (ImageFile, ImageData, SizeOf (ImageData), BytesRead);
  205.     FPos := FilePos (ImageFile);
  206.     Close (ImageFile);
  207.     IF (IOResult = 0) AND (BytesRead = SizeOf (ImageData)) THEN
  208.       WITH ImageData DO BEGIN
  209.         IF (Copy (i_version, 1, 3) = 'GIF') THEN
  210.         BEGIN
  211.           IsGIF := TRUE;
  212.           rez := (2 SHL (i_colors AND 7));  {formula from SWAG}
  213.           Write (i_version:10, '   [', i_width:4, i_height:5, rez:5, ' ]');
  214.           CheckGIFlite (FName, FPos+2, rez) {FPos+2 accounts for "background"}
  215.         END;
  216.       END;
  217.   END;
  218.   GetGIFInfo := IsGIF;
  219. END;
  220.  
  221. FUNCTION GetJPGInfo (CONST FName: STRING): BOOLEAN;
  222. {Checks if file FName is a (true) JPeg/JFIF file and extracts the
  223.  height and width (in pixels) of the image, and determines if image is color}
  224.  
  225. VAR
  226.   ImageFile : FILE;
  227.   ImageData : ARRAY [1..11] OF CHAR;
  228.   BytesRead : WORD;
  229.   Index : INTEGER;
  230.   Height, Width, Color: WORD;
  231.   IsJPG : BOOLEAN;
  232.   BlockLength : LongInt;
  233.  
  234. BEGIN
  235.   IsJPG := FALSE;
  236.  
  237.   Assign (ImageFile, FName);
  238.   Reset (ImageFile, 1);
  239.  
  240.   FillChar (ImageData [1], SizeOf(ImageData), #0);
  241.   BlockRead (ImageFile, ImageData [1], SizeOf(ImageData), BytesRead);
  242.  
  243.   IF (IOResult = 0) AND
  244.      (BytesRead = SizeOf(ImageData)) AND
  245.      (ImageData [1]  = #$FF) AND   {JFIF marker: $FF SOI $FF App0}
  246.      (ImageData [2]  = #$D8) AND
  247.      (ImageData [3]  = #$FF) AND
  248.      (ImageData [4]  = #$E0) AND
  249.    { (ImageData [5]  = length - MSB and }
  250.    { (ImageData [6]  = length - LSB and }
  251.      (ImageData [7]  = 'J') AND
  252.      (ImageData [8]  = 'F') AND
  253.      (ImageData [9]  = 'I') AND
  254.      (ImageData [10] = 'F') AND
  255.      (ImageData [11] = #0)
  256.   THEN IsJPG := TRUE;
  257.  
  258.   IF IsJPG THEN
  259.   BEGIN {We have a JPeg/JFIF File!}
  260.  
  261.     Seek(ImageFile, 4); {Restore to position right after first block sig}
  262.     BlockLength := 256*Ord(ImageData[5]) + Ord(ImageData[6]);
  263.  
  264.     REPEAT   {Search for SOF marker}
  265.  
  266.       Seek (ImageFile, FilePos(ImageFile) + BlockLength);
  267.  
  268.       BlockRead (ImageFile, ImageData [1], 4, BytesRead);
  269.       BlockLength := 256*Ord(ImageData[3]) + Ord(ImageData[4]) - 2;
  270.  
  271.     UNTIL (BytesRead <> 4) OR (ImageData [2] = #$C0);
  272.  
  273.     IF ImageData[2]=#$C0 THEN BEGIN
  274.       Seek (ImageFile, FilePos(ImageFile) - 2);
  275.       BlockRead (ImageFile, ImageData [1], SizeOf(ImageData), BytesRead);
  276.  
  277.       IF BytesRead = SizeOf(ImageData) THEN
  278.       BEGIN
  279.         Index := 0;
  280.       { ImageData[Index] = first SOF marker
  281.         Index + 1 = length high byte  \ length of APP0 data!
  282.         Index + 2 = length low byte   /
  283.         Index + 3 = data precision    - colors (?)
  284.         Index + 4 = height high byte  \ heigth of picture
  285.         Index + 5 = height low byte   /
  286.         Index + 6 = width high byte   \ width of picture
  287.         Index + 7 = width low byte    / }
  288.  
  289.         Height := WORD (Ord (ImageData [Index + 4]) * 256) + Ord (ImageData [Index + 5]);
  290.         Width  := WORD (Ord (ImageData [Index + 6]) * 256) + Ord (ImageData [Index + 7]);
  291.         Color  := Ord (ImageData [Index + 8]);
  292.       END;
  293.     END;
  294.   END;
  295.   IF IsJPG THEN
  296.     BEGIN
  297.       Write ('JPEG ': 10, '   [', Width: 4, Height: 5);
  298.       IF Color > 1
  299.         THEN WriteLn (' color]')
  300.         ELSE WriteLn (' grey ]');
  301.     END;
  302.   Close (ImageFile);
  303.   GetJPGInfo := IsJPG;
  304. END;
  305.  
  306. PROCEDURE Swap32 (VAR LongVar : LONGINT); ASSEMBLER;
  307. ASM {Swap a 32 bit variable (MSB<->LSB).}
  308.   les     SI, LongVar
  309.   mov     AX, ES: [SI]
  310.   mov     DX, ES: [SI + 2]
  311.   xchg    AL, DH
  312.   xchg    AH, DL
  313.   mov     ES: [SI], AX
  314.   mov     ES: [SI + 2], DX
  315. END {Swap32};
  316.  
  317. PROCEDURE Process_IHDR (VAR ImageFile: FILE);
  318. VAR
  319.   PNGHead : RECORD {see the PNG spec, draft #9}
  320.               Width, Height  : LONGINT;
  321.               BitsPerSample  : BYTE;
  322.               ColorType      : BYTE;
  323.               CM, Filter, IL : BYTE
  324.             END;
  325.   Colors : String[3];
  326.   BytesRead : WORD;
  327.  
  328. BEGIN {Process_IHDR}
  329.   FillChar (PNGHead, SizeOf (PNGHead), #0);
  330.   BlockRead (ImageFile, PNGHead, SizeOf (PNGHead), BytesRead);
  331.   IF (IOResult = 0) AND (BytesRead = SizeOf (PNGHead)) THEN
  332.   WITH PNGHead DO BEGIN
  333.     Swap32 (Width);
  334.     Swap32 (Height);
  335.     CASE (BitsPerSample) OF
  336.       1 : Colors := '2';
  337.       4 : Colors := '16';
  338.       8 : Colors := '256';
  339.       24: Colors := '16m'; {2^24}
  340.      ELSE Colors := '???'
  341.     END;
  342.     Write ('PiNG ': 10, '   [', width: 4, height: 5, colors:5);
  343.     IF ColorType > 1
  344.       THEN WriteLn ('c]')
  345.       ELSE WriteLn ('g]');
  346.   END;
  347. END {Process_IHDR};
  348.  
  349. FUNCTION GetPNGInfo (CONST Fname: STRING): BOOLEAN;
  350. CONST
  351.   PNG_Magic : ARRAY [0..7] OF CHAR = #137'PNG'#13#10#26#10;
  352.   MaxBytes = 1000;
  353.  
  354. VAR
  355.   BufMag    : ARRAY [0..7] OF CHAR;
  356.   ImageFile : FILE;
  357.   ImageData : ARRAY [1..MaxBytes] OF CHAR;
  358.   BytesRead : WORD;
  359.   Index : INTEGER;
  360.   Found,
  361.   IsPNG : BOOLEAN;
  362.  
  363. BEGIN
  364.   IsPNG := FALSE;
  365.   Assign (ImageFile, FName);
  366.   Reset (ImageFile, 1);
  367.   BlockRead (ImageFile, BufMag, SizeOf(BufMag), BytesRead);
  368.   IF (IOResult = 0) AND (BytesRead = SizeOf(BufMag)) THEN
  369.   BEGIN
  370.     IF (BufMag = PNG_Magic) THEN
  371.     BEGIN
  372.       BlockRead (ImageFile, ImageData [1], MaxBytes, BytesRead);
  373.       index := 0;
  374.       Found := FALSE;
  375.       REPEAT
  376.         Inc (index);
  377.         IF (ImageData [index]   = 'I') AND
  378.            (ImageData [index+1] = 'H') AND
  379.            (ImageData [index+2] = 'D') AND
  380.            (ImageData [index+3] = 'R')
  381.         THEN FOUND := TRUE;
  382.       UNTIL Found OR (index + 10 > BytesRead);
  383.       If Found Then Begin
  384.         IsPNG := TRUE;
  385.         Seek(ImageFile, Index+3+SizeOf(BufMag));  {Seek is zero based}
  386.         Process_IHDR (ImageFile);
  387.       End;
  388.     END;
  389.   END;
  390.   Close (ImageFile);
  391.   GetPNGInfo := IsPNG;
  392. END {Main};
  393.  
  394. FUNCTION GetPCXInfo (CONST FName: STRING): BOOLEAN;
  395. TYPE
  396.   PCXHeader = RECORD
  397.                 Signature    : CHAR;
  398.                 Version      : CHAR;
  399.                 Encoding     : CHAR;
  400.                 BitsPerPixel : CHAR;
  401.                 XMin, YMin,
  402.                 XMax, YMax   : INTEGER;
  403.                 HRes, VRes   : INTEGER;
  404.                 Palette      : ARRAY [0..47] OF BYTE;
  405.                 Reserved     : CHAR;
  406.                 Planes       : CHAR;
  407.                 BytesPerLine : INTEGER;
  408.                 PALETTETYPE  : INTEGER;
  409.                 Filler       : ARRAY [0..57] OF BYTE;
  410.               END;
  411.  
  412. VAR
  413.   header: PCXHeader;
  414.   width, depth: WORD;
  415.   colors: WORD;
  416.   ImageFile: FILE;
  417.   BytesRead : WORD;
  418.   IsPCX : BOOLEAN;
  419.  
  420. BEGIN
  421.   IsPCX := FALSE;
  422.   Assign (ImageFile, FName);
  423.   Reset (ImageFile, 1);
  424.   BlockRead (ImageFile, header, SizeOf (header), BytesRead);
  425.   Close (ImageFile);
  426.   IF (IOResult = 0) AND (BytesRead = SizeOf (header)) THEN
  427.   WITH header DO
  428.     IF (Signature = #10) AND (Ord(Version) in [0,2,3,4,5]) THEN
  429.     BEGIN
  430.       IsPCX := TRUE;
  431.       width := XMax - XMin + 1;
  432.       depth := YMax - YMin + 1;
  433.       colors := 1 SHL (Ord(Planes)*Ord(BitsPerPixel));
  434.       WriteLn ('PCX  ':10, '   [', width:4, depth:5, colors:5, ' ]');
  435.     END;
  436.   GetPCXInfo := IsPCX;
  437. END;
  438.  
  439. (*****************************************************************************)
  440.  
  441. VAR
  442.   image_name,
  443.   gpath: STRING; gdir: DIRSTR; gname: NAMESTR; gext: EXTSTR;
  444.   dirinfo: SEARCHREC;
  445.   numfiles: WORD; sizefiles: LONGINT;
  446.  
  447. BEGIN
  448.   FileMode := 0;
  449.   numfiles := 0;
  450.   sizefiles := 0;
  451.   getpath (gpath);
  452.   FSplit (FExpand (gpath), gdir, gname, gext);
  453.   gpath := gdir + gname+ gext;
  454.   FindFirst (gpath, ReadOnly+Hidden+Archive, dirinfo);
  455.   IF (DosError <> 0) THEN showhelp (1);
  456.   WriteLn ('Image Directory of: '+gpath+lf);
  457.   WHILE (DosError = 0) DO BEGIN
  458.     image_name := gdir + dirinfo. Name;
  459.     Write ((RPad (dirinfo. Name, 12)), dirinfo. Size : 9);
  460.     Inc (numfiles);
  461.     Inc (sizefiles, dirinfo. Size);
  462.     writetime (dirinfo. Time);
  463.     IF dirinfo.Size > 0 THEN
  464.     BEGIN
  465.      IF NOT GetGIFInfo (image_name) THEN
  466.       IF NOT GetJPGInfo (image_name) THEN
  467.        IF NOT GetBMPInfo (image_name) THEN
  468.         IF NOT GetPNGInfo (image_name) THEN
  469.          IF NOT GetPCXInfo (image_name) THEN
  470.           WriteLn; {-or- WriteLn (' ... Unrecognized format - skipping.');}
  471.     END
  472.     ELSE WriteLn;
  473.     FindNext (dirinfo);
  474.   END;
  475.   WriteLn (comma (sizefiles):12,' bytes in ', numfiles, ' file(s)');
  476. END.
  477.