ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/FILE/FILTYP11.ZIP/FILETYPE.PAS

Pascal/Delphi Source File | 1991-08-19 | 16.0 KB | 408 lines

Program filetype;
{ Partial Un*x 'file' clone: use magic sequences to guess at file type       }
{ Free Software by TapirSoft Gisbert W.Selke, Jul 1991                       }

{ See the sample Magic.FT or the documentation for an explanation of the     }
{ format of the magic file. Call without parameters for a usage screen.      }

{$A+,B-,D+,E+,F-,I-,L+,N-,O-,R+,S+,V- }
{$M 16384,0,96000 }

  Uses Dos;

  Const progname = 'FileType';
        version  = '1.1';
        copyright= 'Free Software by TapirSoft Gisbert W.Selke, Aug 1991';

        magicname= 'Magic.ft'; { default name of file cont. magic patterns }
        magicid  = ';FTMagic'; { magic file signature }
        minmagic = 1.0;        { minimum Magic.FT version we can handle }
        maxmagic = 1.1;        { maximum Magic.FT version we can handle }
        bufsize  = 64000;      { size of I/O buffer for magic file }
        examsize = 31000;      { size of I/O buffers for file to be tested }
        magicsize= 256;        { maximum pattern and mask length }
        Tab      = #9;

  Type iobuff     = Array [0..bufsize] Of byte;
       exambuffer = Array [0..examsize-1] Of byte;
       transbuff  = Array [0..255] Of byte;
       magicbuff  = Array [0..magicsize-1] Of byte;
       nocasebuff = Array [0..magicsize-1] Of boolean;

  Var magicfile : text;
      testfile : File;
      exambuff : Array [0..1] Of exambuffer;
      examlen : Array [0..1] Of word;
      maskbuff, magic : magicbuff;
      translat, transl, transu : transbuff;
      inbufptr: ^iobuff;
      nocase : nocasebuff;
      fname, mname, temp : string;
      pos2, matchpos, testfsize : longint;
      examstart : word;
      translen : integer;
      i, magiclen, masklen, buffno : byte;
      match, nextcont : boolean;

  Procedure abort(errmsg : string; retcode : byte);
  { show error message (if any) and die                                      }
  Begin                                                              { abort }
    If errmsg <> '' Then writeln(progname,': ',errmsg);
    Halt(retcode);
  End;                                                               { abort }

  Procedure usage;
  { show usage hints and die                                                 }
  Begin                                                              { usage }
    writeln(progname,' ',version,' -- ',copyright);
    writeln('Using magic numbers, try to find out type of given file');
    writeln('Usage: ',progname,' [/m<magicfile>] [/q] <filename>');
    writeln('       Default for <magicfile> is ',magicname,'.');
    writeln('       /q (quiet) suppresses vanity message.');
    abort('',1);
  End;                                                               { usage }

  {$F+ } Function myheaperrfunc(size : word) : integer; {$F- }
  { handle heap errors safely - don't really need the heap anyway            }
  Begin                                                      { myheaperrfunc }
    myheaperrfunc := 1;
  End;                                                       { myheaperrfunc }

  Procedure strip(Var s : string);
  { strip leading blanks and tabs from s                                     }
  Begin                                                              { strip }
    While (s <> '') And ((s[1] = ' ') Or (s[1] = Tab)) Do Delete(s,1,1);
  End;                                                               { strip }

  Function hex2num(c : char): byte;
  { convert a hex digit to a number value                                    }
  Begin                                                            { hex2num }
    Case UpCase(c) Of
      '0'..'9' : hex2num := Ord(c) - Ord('0');
      'A'..'Z' : hex2num := Ord(UpCase(c)) - Ord('A') + 10;
      Else hex2num := 0;
    End;
  End;                                                             { hex2num }

  Procedure getargs;
  { get command line arguments, init vars                                    }
    Var i : byte;
        quiet : boolean;
  Begin                                                            { getargs }
    mname := '';
    fname := '';
    quiet := False;
    For i := 1 To ParamCount Do
    Begin
      temp:= ParamStr(i);
      If (temp[1] = '/') Or (temp[1] = '-') Then
      Begin { switches start with '-' or '/' }
        If Length(temp) <= 1 Then usage;
        Case UpCase(temp[2]) Of
          'Q' : quiet := True;
          'M' : Begin { magic file name }
                  If Length(temp) = 2 Then usage;
                  mname := Copy(temp,3,255);
                End;
          Else  usage;
        End;
      End
      Else
      Begin
        If fname <> ''Then usage; { at most one file per call }
        fname := temp;
      End;
    End;
    If fname = '' Then usage; { at least one file per call }
    If mname = '' Then mname := magicname;
    If Not quiet Then writeln(progname,' ',version,' -- ',copyright);
  End;                                                             { getargs }

  Procedure transini;
  { initialize translation table from DOS, if possible; else clear it        }
    Var regs : Registers;
        dosbuff : Array [0..4] Of byte;
        tabseg, tabofs, tabsiz : word;
        i : byte;

  Begin                                                           { transini }
    translen := 0;
    For i := 0 To 255 Do translat[i] := i;
    For i := Ord('a') To Ord('z') Do translat[i] := byte(UpCase(char(i)));
    tabsiz := DosVersion;
    If (Lo(tabsiz) > 3) Or ((Lo(tabsiz) = 3) And (Hi(tabsiz) >= 30)) Then
    Begin { country-dependent translation table available from DOS 3.30+ }
      With regs Do
      Begin
        ax := $6502; { function/subfunction: get uppercase table }
        bx := $FFFF; { global code page }
        dx := $FFFF; { current country }
        cx := SizeOf(dosbuff);
        es:= Seg(dosbuff);
        di:= Ofs(dosbuff);
      End;
      MsDos(regs);
      If ((regs.Flags And FCarry) = 0) And (dosbuff[0] = $02) Then
      Begin { info is ok }
        tabofs := dosbuff[1] Or (word(dosbuff[2]) ShL 8);
        tabseg := dosbuff[3] Or (word(dosbuff[4]) ShL 8);
        tabsiz := MemW[tabseg:tabofs];
        For i := 1 To tabsiz Do translat[i+127] := Mem[tabseg:tabofs+i+1];
      End;
    End;
  End;                                                            { transini }

  Procedure gettestfile;
  { gets name of testfile, reads starting buffer                             }
  Begin                                                        { gettestfile }
    FileMode := 0;
    Assign(testfile,fname);
    Reset(testfile,1);
    If IOResult <> 0 Then abort('Cannot find '+fname,2);
    BlockRead(testfile,exambuff[0],examsize,examlen[0]);
                              { most sequences will start at top-of-file }
    If IOResult <> 0 Then abort('Cannot read '+fname,3);
    If examlen[0] = 0 Then abort(fname+': empty file',0);
    testfsize := FileSize(testfile);
    pos2 := 0;
    examlen[1] := 0;
  End;                                                         { gettestfile }

  Procedure openmagicfile;
  { find and open magic file                                                 }
    Var temp1, temp2 : string;
        rver : real;
        ierr : integer;
  Begin                                                      { openmagicfile }
    Assign(magicfile,mname); { try current (or specified) directory }
    Reset(magicfile);
    If IOResult <> 0 Then
    Begin
      temp1 := ParamStr(0);
      While (temp1 <> '') And (Not (temp1[Length(temp1)] In ['\',':'])) Do
                                                Delete(temp1,Length(temp1),1);
      Assign(magicfile,temp1+mname); { try FileType.EXE's home dir }
      Reset(magicfile);
      If IOResult <> 0 Then abort('Cannot find magic file '+mname,4);
      mname := temp1 + mname;
    End;
    New(inbufptr);
    If inbufptr <> Nil Then SetTextBuf(magicfile,inbufptr^);
    readln(magicfile,temp1);
    Val(Copy(temp1,Succ(Length(magicid)),3),rver,ierr);
    If (Copy(temp1,1,Length(magicid)) <> magicid) Or (ierr <> 0) Then
          abort(mname+' is not a valid '+progname+' magic number file',6);
                             { minimal check for valid magic file failed }
    If (rver < minmagic) Or (rver > maxmagic) Then
    Begin
      Str(minmagic:3:1,temp1);
      If minmagic <> maxmagic Then
      Begin
        Str(maxmagic:3:1,temp2);
        temp1 := 'between ' + temp1 + ' and ' + temp2;
      End;
      abort('Magic file '+mname+' has incorrect version; must be '+temp1,7);
    End;
  End;                                                       { openmagicfile }

  Procedure gettrans(Var s : string; Var trans : transbuff);
  { get a case translation line                                              }
    Var i : byte;
  Begin                                                           { gettrans }
    For i := 0 To 255 Do trans[i] := 0;
    For i := 2 To Length(s) Do trans[i] := byte(s[i]);
    translen := Pred(Length(s));
    For i := 0 To 255 Do translat[i] := i;
    For i := Ord('a') To Ord('z') Do translat[i] := byte(UpCase(char(i)));
    For i := 0 To translen-1 Do translat[transl[i]] := transu[i];
    s := '';
  End;                                                            { gettrans }

  Procedure getsequence(Var s : string; Var buff : magicbuff; Var len : byte;
                        updcase : boolean);
  { extract a magic (or mask) sequence from an input line                    }

    Var quote : char;
        ival, stuffit : byte;
        escaped, ignocase : boolean;

  Begin                                                        { getsequence }
    quote := #0;
    len := 0;
    stuffit := 0;
    ival:= 0;
    ignocase := False;
    While (s <> '') And ((UpCase(s[1]) In ['0'..'9','A'..'F','''','"','?']) Or
                         (quote <> #0)) Do
    Begin
      If quote = #0 Then
      Begin { reading hex digits }
        escaped := False;
        Case UpCase(s[1]) Of
          '''','"' : Begin { start of ASCII string }
                       quote := s[1];
                       ignocase := s[1] = '"'; { double quotes for case-independence }
                       stuffit := 0;           { don't stuff quotes }
                     End;
          '?'      : stuffit := 3;             { any which way but match }
          '0'..'9', 'A'..'Z' : Begin           { hex digit }
                       ival := (ival ShL 4) Or hex2num(s[1]);
                       Inc(stuffit);
                     End;
        End; { others are ignored }
      End
      Else
      Begin { handling ASCII string }
        If escaped Then
        Begin { previous char was '\' }
          Case s[1] Of
            'b' : ival :=  8; { backspace }
            't' : ival :=  9; { tab }
            'n' : ival := 10; { new line (LF) }
            'v' : ival := 11; { vertical tab }
            'f' : ival := 12; { form feed }
            'r' : ival := 13; { carriage return }
            Else ival := byte(s[1]); { others: literally }
          End;
          escaped := False;
          stuffit := 2;     { ready to stuff }
        End
        Else
        Begin { ASCII string, not escaped }
          Case s[1] Of
            '\' : Begin { skip this, next one gets special treatment }
                    escaped := True;
                    stuffit := 0;
                  End;
            '?' : Begin { any which  one but match }
                    ival := 0;
                    stuffit := 3;
                  End;
            Else Begin   { ordinary char }
                   If s[1] = quote Then
                   Begin { end of string }
                     quote := #0;
                     ignocase := False;
                     stuffit := 0; { don't stuff quote }
                   End
                   Else
                   Begin
                     ival := byte(s[1]); { at long last }
                     stuffit := 2;
                   End;
                 End;
          End;
        End;
      End;
      If stuffit >= 2 Then { complete char }
      Begin
        If stuffit = 3 Then maskbuff[len] := $0; { any char }
        If ignocase Then buff[len] := translat[ival] { case-independent }
                    Else buff[len] := ival;      { ordinary match }
        nocase[len] := ignocase;                 { note case-independence }
        Inc(len);
        ival := 0;
        stuffit := 0;
      End;
      Delete(s,1,1);
    End;
  End;                                                         { getsequence }

  Function getmatchpos(Var s : string) : longint;
  { extracts a file offset from an input line                                }
    Var nega : boolean;
        mp : longint;
  Begin                                                        { getmatchpos }
    Delete(s,1,1);
    nega := False;
    If s[1] = '-' Then
    Begin
      nega := True;
      Delete(s,1,1);
    End;
    mp := 0;
    While (s <> '') And (UpCase(s[1]) In ['0'..'9','A'..'F']) Do
    Begin { convert hex to bin }
      mp := 16*mp + hex2num(s[1]);
      Delete(s,1,1);
    End;
    If nega Then mp := testfsize - mp; { calc ofset from end }
    If mp < 0 Then mp := 0;
    strip(s);
    getmatchpos := mp;
  End;                                                         { getmatchpos }

Begin
  getargs;         { process cmd line }
  transini;
  HeapError := @myheaperrfunc;
  gettestfile;     { strange encounters for the first time }
  openmagicfile;   { try to find magic file }
  match := False;
  nextcont := False;
  While Not(EoF(magicfile)) And (Not(match) Or nextcont) Do
  Begin                     { walk through magic file }
    readln(magicfile,temp); { get line from magic file }
    If IOResult <> 0 Then abort('Error reading magic number file '+mname,5);
    strip(temp);
    { first check for translation lines: }
    If (temp <> '') And (UpCase(temp[1]) = 'V') Then gettrans(temp,transl);
    If (temp <> '') And (temp[1] = '^')         Then gettrans(temp,transu);
    If (temp <> '') And (temp[1] <> '#') And (temp[1] <> ';') Then
    Begin { non-empty, non-comment }
      matchpos := 0;
      If temp[1] = '@' Then matchpos := getmatchpos(temp); { get match pos }
      masklen := 0;
      FillChar(maskbuff,SizeOf(maskbuff),#255); { init AND-mask }
      If temp[1] = '&' Then
      Begin { read AND-mask }
        Delete(temp,1,1);
        getsequence(temp,maskbuff,masklen,False);
        strip(temp);
      End;
      getsequence(temp,magic,magiclen,True); { get identifying sequence }
      strip(temp);
      If match Or Not nextcont Then
      Begin
        If matchpos+magiclen <= examsize Then
        Begin { match near top-of-file is asked for }
          buffno := 0;
          examstart := matchpos;
        End
        Else
        Begin { match somewhere deep down in the file is asked for }
          buffno := 1;
          If (matchpos < pos2) Or (matchpos+magiclen > pos2+examlen[1]) Then
          Begin  { read appropriate file section }
            pos2 := matchpos;
            If pos2+examsize > testfsize Then pos2 := testfsize - examsize;
            If pos2 < 0 Then pos2 := 0;
            Seek(testfile,pos2);
            BlockRead(testfile,exambuff[1],examsize,examlen[1]);
          End;
          examstart := matchpos - pos2; { calculate offset into buffer }
        End;
        match := False;
        If examstart+magiclen <= examlen[buffno] Then
        Begin
          match := True;
          i := 0;
          While match And (i < magiclen) Do
          Begin { try to match }
            If nocase[i] Then match := (magic[i] =
                       (translat[exambuff[buffno,i+examstart]] And maskbuff[i]))
                         Else match := (magic[i] =
                                 (exambuff[buffno,i+examstart] And maskbuff[i]));
            Inc(i);
          End;
        End;
      End;
      nextcont := temp = '/';
    End;
  End;
  Close(magicfile);
  Close(testfile);
  If Not match Then temp := 'unknown';
  writeln(fname,': ',temp);
End.