home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-386-Vol-2of3.iso / f / filtyp11.zip / FILETYPE.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-19  |  16KB  |  408 lines
  1. Program filetype;
  2. { Partial Un*x 'file' clone: use magic sequences to guess at file type       }
  3. { Free Software by TapirSoft Gisbert W.Selke, Jul 1991                       }
  4.  
  5. { See the sample Magic.FT or the documentation for an explanation of the     }
  6. { format of the magic file. Call without parameters for a usage screen.      }
  7.  
  8. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,R+,S+,V- }
  9. {$M 16384,0,96000 }
  10.  
  11.   Uses Dos;
  12.  
  13.   Const progname = 'FileType';
  14.         version  = '1.1';
  15.         copyright= 'Free Software by TapirSoft Gisbert W.Selke, Aug 1991';
  16.  
  17.         magicname= 'Magic.ft'; { default name of file cont. magic patterns }
  18.         magicid  = ';FTMagic'; { magic file signature }
  19.         minmagic = 1.0;        { minimum Magic.FT version we can handle }
  20.         maxmagic = 1.1;        { maximum Magic.FT version we can handle }
  21.         bufsize  = 64000;      { size of I/O buffer for magic file }
  22.         examsize = 31000;      { size of I/O buffers for file to be tested }
  23.         magicsize= 256;        { maximum pattern and mask length }
  24.         Tab      = #9;
  25.  
  26.   Type iobuff     = Array [0..bufsize] Of byte;
  27.        exambuffer = Array [0..examsize-1] Of byte;
  28.        transbuff  = Array [0..255] Of byte;
  29.        magicbuff  = Array [0..magicsize-1] Of byte;
  30.        nocasebuff = Array [0..magicsize-1] Of boolean;
  31.  
  32.   Var magicfile : text;
  33.       testfile : File;
  34.       exambuff : Array [0..1] Of exambuffer;
  35.       examlen : Array [0..1] Of word;
  36.       maskbuff, magic : magicbuff;
  37.       translat, transl, transu : transbuff;
  38.       inbufptr: ^iobuff;
  39.       nocase : nocasebuff;
  40.       fname, mname, temp : string;
  41.       pos2, matchpos, testfsize : longint;
  42.       examstart : word;
  43.       translen : integer;
  44.       i, magiclen, masklen, buffno : byte;
  45.       match, nextcont : boolean;
  46.  
  47.   Procedure abort(errmsg : string; retcode : byte);
  48.   { show error message (if any) and die                                      }
  49.   Begin                                                              { abort }
  50.     If errmsg <> '' Then writeln(progname,': ',errmsg);
  51.     Halt(retcode);
  52.   End;                                                               { abort }
  53.  
  54.   Procedure usage;
  55.   { show usage hints and die                                                 }
  56.   Begin                                                              { usage }
  57.     writeln(progname,' ',version,' -- ',copyright);
  58.     writeln('Using magic numbers, try to find out type of given file');
  59.     writeln('Usage: ',progname,' [/m<magicfile>] [/q] <filename>');
  60.     writeln('       Default for <magicfile> is ',magicname,'.');
  61.     writeln('       /q (quiet) suppresses vanity message.');
  62.     abort('',1);
  63.   End;                                                               { usage }
  64.  
  65.   {$F+ } Function myheaperrfunc(size : word) : integer; {$F- }
  66.   { handle heap errors safely - don't really need the heap anyway            }
  67.   Begin                                                      { myheaperrfunc }
  68.     myheaperrfunc := 1;
  69.   End;                                                       { myheaperrfunc }
  70.  
  71.   Procedure strip(Var s : string);
  72.   { strip leading blanks and tabs from s                                     }
  73.   Begin                                                              { strip }
  74.     While (s <> '') And ((s[1] = ' ') Or (s[1] = Tab)) Do Delete(s,1,1);
  75.   End;                                                               { strip }
  76.  
  77.   Function hex2num(c : char): byte;
  78.   { convert a hex digit to a number value                                    }
  79.   Begin                                                            { hex2num }
  80.     Case UpCase(c) Of
  81.       '0'..'9' : hex2num := Ord(c) - Ord('0');
  82.       'A'..'Z' : hex2num := Ord(UpCase(c)) - Ord('A') + 10;
  83.       Else hex2num := 0;
  84.     End;
  85.   End;                                                             { hex2num }
  86.  
  87.   Procedure getargs;
  88.   { get command line arguments, init vars                                    }
  89.     Var i : byte;
  90.         quiet : boolean;
  91.   Begin                                                            { getargs }
  92.     mname := '';
  93.     fname := '';
  94.     quiet := False;
  95.     For i := 1 To ParamCount Do
  96.     Begin
  97.       temp:= ParamStr(i);
  98.       If (temp[1] = '/') Or (temp[1] = '-') Then
  99.       Begin { switches start with '-' or '/' }
  100.         If Length(temp) <= 1 Then usage;
  101.         Case UpCase(temp[2]) Of
  102.           'Q' : quiet := True;
  103.           'M' : Begin { magic file name }
  104.                   If Length(temp) = 2 Then usage;
  105.                   mname := Copy(temp,3,255);
  106.                 End;
  107.           Else  usage;
  108.         End;
  109.       End
  110.       Else
  111.       Begin
  112.         If fname <> ''Then usage; { at most one file per call }
  113.         fname := temp;
  114.       End;
  115.     End;
  116.     If fname = '' Then usage; { at least one file per call }
  117.     If mname = '' Then mname := magicname;
  118.     If Not quiet Then writeln(progname,' ',version,' -- ',copyright);
  119.   End;                                                             { getargs }
  120.  
  121.   Procedure transini;
  122.   { initialize translation table from DOS, if possible; else clear it        }
  123.     Var regs : Registers;
  124.         dosbuff : Array [0..4] Of byte;
  125.         tabseg, tabofs, tabsiz : word;
  126.         i : byte;
  127.  
  128.   Begin                                                           { transini }
  129.     translen := 0;
  130.     For i := 0 To 255 Do translat[i] := i;
  131.     For i := Ord('a') To Ord('z') Do translat[i] := byte(UpCase(char(i)));
  132.     tabsiz := DosVersion;
  133.     If (Lo(tabsiz) > 3) Or ((Lo(tabsiz) = 3) And (Hi(tabsiz) >= 30)) Then
  134.     Begin { country-dependent translation table available from DOS 3.30+ }
  135.       With regs Do
  136.       Begin
  137.         ax := $6502; { function/subfunction: get uppercase table }
  138.         bx := $FFFF; { global code page }
  139.         dx := $FFFF; { current country }
  140.         cx := SizeOf(dosbuff);
  141.         es:= Seg(dosbuff);
  142.         di:= Ofs(dosbuff);
  143.       End;
  144.       MsDos(regs);
  145.       If ((regs.Flags And FCarry) = 0) And (dosbuff[0] = $02) Then
  146.       Begin { info is ok }
  147.         tabofs := dosbuff[1] Or (word(dosbuff[2]) ShL 8);
  148.         tabseg := dosbuff[3] Or (word(dosbuff[4]) ShL 8);
  149.         tabsiz := MemW[tabseg:tabofs];
  150.         For i := 1 To tabsiz Do translat[i+127] := Mem[tabseg:tabofs+i+1];
  151.       End;
  152.     End;
  153.   End;                                                            { transini }
  154.  
  155.   Procedure gettestfile;
  156.   { gets name of testfile, reads starting buffer                             }
  157.   Begin                                                        { gettestfile }
  158.     FileMode := 0;
  159.     Assign(testfile,fname);
  160.     Reset(testfile,1);
  161.     If IOResult <> 0 Then abort('Cannot find '+fname,2);
  162.     BlockRead(testfile,exambuff[0],examsize,examlen[0]);
  163.                               { most sequences will start at top-of-file }
  164.     If IOResult <> 0 Then abort('Cannot read '+fname,3);
  165.     If examlen[0] = 0 Then abort(fname+': empty file',0);
  166.     testfsize := FileSize(testfile);
  167.     pos2 := 0;
  168.     examlen[1] := 0;
  169.   End;                                                         { gettestfile }
  170.  
  171.   Procedure openmagicfile;
  172.   { find and open magic file                                                 }
  173.     Var temp1, temp2 : string;
  174.         rver : real;
  175.         ierr : integer;
  176.   Begin                                                      { openmagicfile }
  177.     Assign(magicfile,mname); { try current (or specified) directory }
  178.     Reset(magicfile);
  179.     If IOResult <> 0 Then
  180.     Begin
  181.       temp1 := ParamStr(0);
  182.       While (temp1 <> '') And (Not (temp1[Length(temp1)] In ['\',':'])) Do
  183.                                                 Delete(temp1,Length(temp1),1);
  184.       Assign(magicfile,temp1+mname); { try FileType.EXE's home dir }
  185.       Reset(magicfile);
  186.       If IOResult <> 0 Then abort('Cannot find magic file '+mname,4);
  187.       mname := temp1 + mname;
  188.     End;
  189.     New(inbufptr);
  190.     If inbufptr <> Nil Then SetTextBuf(magicfile,inbufptr^);
  191.     readln(magicfile,temp1);
  192.     Val(Copy(temp1,Succ(Length(magicid)),3),rver,ierr);
  193.     If (Copy(temp1,1,Length(magicid)) <> magicid) Or (ierr <> 0) Then
  194.           abort(mname+' is not a valid '+progname+' magic number file',6);
  195.                              { minimal check for valid magic file failed }
  196.     If (rver < minmagic) Or (rver > maxmagic) Then
  197.     Begin
  198.       Str(minmagic:3:1,temp1);
  199.       If minmagic <> maxmagic Then
  200.       Begin
  201.         Str(maxmagic:3:1,temp2);
  202.         temp1 := 'between ' + temp1 + ' and ' + temp2;
  203.       End;
  204.       abort('Magic file '+mname+' has incorrect version; must be '+temp1,7);
  205.     End;
  206.   End;                                                       { openmagicfile }
  207.  
  208.   Procedure gettrans(Var s : string; Var trans : transbuff);
  209.   { get a case translation line                                              }
  210.     Var i : byte;
  211.   Begin                                                           { gettrans }
  212.     For i := 0 To 255 Do trans[i] := 0;
  213.     For i := 2 To Length(s) Do trans[i] := byte(s[i]);
  214.     translen := Pred(Length(s));
  215.     For i := 0 To 255 Do translat[i] := i;
  216.     For i := Ord('a') To Ord('z') Do translat[i] := byte(UpCase(char(i)));
  217.     For i := 0 To translen-1 Do translat[transl[i]] := transu[i];
  218.     s := '';
  219.   End;                                                            { gettrans }
  220.  
  221.   Procedure getsequence(Var s : string; Var buff : magicbuff; Var len : byte;
  222.                         updcase : boolean);
  223.   { extract a magic (or mask) sequence from an input line                    }
  224.  
  225.     Var quote : char;
  226.         ival, stuffit : byte;
  227.         escaped, ignocase : boolean;
  228.  
  229.   Begin                                                        { getsequence }
  230.     quote := #0;
  231.     len := 0;
  232.     stuffit := 0;
  233.     ival:= 0;
  234.     ignocase := False;
  235.     While (s <> '') And ((UpCase(s[1]) In ['0'..'9','A'..'F','''','"','?']) Or
  236.                          (quote <> #0)) Do
  237.     Begin
  238.       If quote = #0 Then
  239.       Begin { reading hex digits }
  240.         escaped := False;
  241.         Case UpCase(s[1]) Of
  242.           '''','"' : Begin { start of ASCII string }
  243.                        quote := s[1];
  244.                        ignocase := s[1] = '"'; { double quotes for case-independence }
  245.                        stuffit := 0;           { don't stuff quotes }
  246.                      End;
  247.           '?'      : stuffit := 3;             { any which way but match }
  248.           '0'..'9', 'A'..'Z' : Begin           { hex digit }
  249.                        ival := (ival ShL 4) Or hex2num(s[1]);
  250.                        Inc(stuffit);
  251.                      End;
  252.         End; { others are ignored }
  253.       End
  254.       Else
  255.       Begin { handling ASCII string }
  256.         If escaped Then
  257.         Begin { previous char was '\' }
  258.           Case s[1] Of
  259.             'b' : ival :=  8; { backspace }
  260.             't' : ival :=  9; { tab }
  261.             'n' : ival := 10; { new line (LF) }
  262.             'v' : ival := 11; { vertical tab }
  263.             'f' : ival := 12; { form feed }
  264.             'r' : ival := 13; { carriage return }
  265.             Else ival := byte(s[1]); { others: literally }
  266.           End;
  267.           escaped := False;
  268.           stuffit := 2;     { ready to stuff }
  269.         End
  270.         Else
  271.         Begin { ASCII string, not escaped }
  272.           Case s[1] Of
  273.             '\' : Begin { skip this, next one gets special treatment }
  274.                     escaped := True;
  275.                     stuffit := 0;
  276.                   End;
  277.             '?' : Begin { any which  one but match }
  278.                     ival := 0;
  279.                     stuffit := 3;
  280.                   End;
  281.             Else Begin   { ordinary char }
  282.                    If s[1] = quote Then
  283.                    Begin { end of string }
  284.                      quote := #0;
  285.                      ignocase := False;
  286.                      stuffit := 0; { don't stuff quote }
  287.                    End
  288.                    Else
  289.                    Begin
  290.                      ival := byte(s[1]); { at long last }
  291.                      stuffit := 2;
  292.                    End;
  293.                  End;
  294.           End;
  295.         End;
  296.       End;
  297.       If stuffit >= 2 Then { complete char }
  298.       Begin
  299.         If stuffit = 3 Then maskbuff[len] := $0; { any char }
  300.         If ignocase Then buff[len] := translat[ival] { case-independent }
  301.                     Else buff[len] := ival;      { ordinary match }
  302.         nocase[len] := ignocase;                 { note case-independence }
  303.         Inc(len);
  304.         ival := 0;
  305.         stuffit := 0;
  306.       End;
  307.       Delete(s,1,1);
  308.     End;
  309.   End;                                                         { getsequence }
  310.  
  311.   Function getmatchpos(Var s : string) : longint;
  312.   { extracts a file offset from an input line                                }
  313.     Var nega : boolean;
  314.         mp : longint;
  315.   Begin                                                        { getmatchpos }
  316.     Delete(s,1,1);
  317.     nega := False;
  318.     If s[1] = '-' Then
  319.     Begin
  320.       nega := True;
  321.       Delete(s,1,1);
  322.     End;
  323.     mp := 0;
  324.     While (s <> '') And (UpCase(s[1]) In ['0'..'9','A'..'F']) Do
  325.     Begin { convert hex to bin }
  326.       mp := 16*mp + hex2num(s[1]);
  327.       Delete(s,1,1);
  328.     End;
  329.     If nega Then mp := testfsize - mp; { calc ofset from end }
  330.     If mp < 0 Then mp := 0;
  331.     strip(s);
  332.     getmatchpos := mp;
  333.   End;                                                         { getmatchpos }
  334.  
  335. Begin
  336.   getargs;         { process cmd line }
  337.   transini;
  338.   HeapError := @myheaperrfunc;
  339.   gettestfile;     { strange encounters for the first time }
  340.   openmagicfile;   { try to find magic file }
  341.   match := False;
  342.   nextcont := False;
  343.   While Not(EoF(magicfile)) And (Not(match) Or nextcont) Do
  344.   Begin                     { walk through magic file }
  345.     readln(magicfile,temp); { get line from magic file }
  346.     If IOResult <> 0 Then abort('Error reading magic number file '+mname,5);
  347.     strip(temp);
  348.     { first check for translation lines: }
  349.     If (temp <> '') And (UpCase(temp[1]) = 'V') Then gettrans(temp,transl);
  350.     If (temp <> '') And (temp[1] = '^')         Then gettrans(temp,transu);
  351.     If (temp <> '') And (temp[1] <> '#') And (temp[1] <> ';') Then
  352.     Begin { non-empty, non-comment }
  353.       matchpos := 0;
  354.       If temp[1] = '@' Then matchpos := getmatchpos(temp); { get match pos }
  355.       masklen := 0;
  356.       FillChar(maskbuff,SizeOf(maskbuff),#255); { init AND-mask }
  357.       If temp[1] = '&' Then
  358.       Begin { read AND-mask }
  359.         Delete(temp,1,1);
  360.         getsequence(temp,maskbuff,masklen,False);
  361.         strip(temp);
  362.       End;
  363.       getsequence(temp,magic,magiclen,True); { get identifying sequence }
  364.       strip(temp);
  365.       If match Or Not nextcont Then
  366.       Begin
  367.         If matchpos+magiclen <= examsize Then
  368.         Begin { match near top-of-file is asked for }
  369.           buffno := 0;
  370.           examstart := matchpos;
  371.         End
  372.         Else
  373.         Begin { match somewhere deep down in the file is asked for }
  374.           buffno := 1;
  375.           If (matchpos < pos2) Or (matchpos+magiclen > pos2+examlen[1]) Then
  376.           Begin  { read appropriate file section }
  377.             pos2 := matchpos;
  378.             If pos2+examsize > testfsize Then pos2 := testfsize - examsize;
  379.             If pos2 < 0 Then pos2 := 0;
  380.             Seek(testfile,pos2);
  381.             BlockRead(testfile,exambuff[1],examsize,examlen[1]);
  382.           End;
  383.           examstart := matchpos - pos2; { calculate offset into buffer }
  384.         End;
  385.         match := False;
  386.         If examstart+magiclen <= examlen[buffno] Then
  387.         Begin
  388.           match := True;
  389.           i := 0;
  390.           While match And (i < magiclen) Do
  391.           Begin { try to match }
  392.             If nocase[i] Then match := (magic[i] =
  393.                        (translat[exambuff[buffno,i+examstart]] And maskbuff[i]))
  394.                          Else match := (magic[i] =
  395.                                  (exambuff[buffno,i+examstart] And maskbuff[i]));
  396.             Inc(i);
  397.           End;
  398.         End;
  399.       End;
  400.       nextcont := temp = '/';
  401.     End;
  402.   End;
  403.   Close(magicfile);
  404.   Close(testfile);
  405.   If Not match Then temp := 'unknown';
  406.   writeln(fname,': ',temp);
  407. End.
  408.