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

Pascal/Delphi Source File | 1991-07-31 | 11.5 KB | 352 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,16384 }

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

        magicname= 'Magic.ft';
        magicid  = ';FTMagic1.0';
        bufsize  = 40000;
        examsize = 256;
        Tab      = #9;

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

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

      ctemp : char;

  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.');
    Halt(1);
  End;                                                               { usage }

  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
        If Length(temp) <= 1 Then usage;
        Case UpCase(temp[2]) Of
          'Q' : quiet := True;
          'M' : Begin
                  If Length(temp) = 2 Then usage;
                  mname := Copy(temp,3,255);
                End;
          Else  usage;
        End;
      End
      Else
      Begin
        If fname <> ''Then usage;
        fname := temp;
      End;
    End;
    If fname = '' Then usage;
    If mname = '' Then mname := magicname;
    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)));
    If Not quiet Then writeln(progname,' ',version,' -- ',copyright);
  End;                                                             { getargs }

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

  Procedure openmagicfile;
  { find and open magic file                                                 }
  Begin                                                      { openmagicfile }
    Assign(magicfile,mname);
    Reset(magicfile);
    If IOResult <> 0 Then
    Begin
      temp:= ParamStr(0);
      While (temp <> '') And (Not (temp[Length(temp)] In ['\',':'])) Do
                                                  Delete(temp,Length(temp),1);
      Assign(magicfile,temp+mname);
      Reset(magicfile);
      If IOResult <> 0 Then
      Begin
        writeln('Cannot find magic file ',mname);
        Halt(4);
      End;
      mname := temp + mname;
    End;
    SetTextBuf(magicfile,magicbuff);
    readln(magicfile,temp);
    If Copy(temp,1,Length(magicid)) <> magicid Then
    Begin
      writeln(mname,' is not a valid ',progname,' magic number file');
      Halt(6);
    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 : exambuffer; 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
        escaped := False;
        Case UpCase(s[1]) Of
          '''','"' : Begin
                       quote := s[1];
                       ignocase := s[1] = '"';
                       stuffit := 0;
                     End;
          '?'      : stuffit := 3;
          '0'..'9', 'A'..'Z' : Begin
                       ival := (ival ShL 4) Or hex2num(s[1]);
                       Inc(stuffit);
                     End;
        End;
      End
      Else
      Begin
        If escaped Then
        Begin
          Case s[1] Of
            'b' : ival :=  8;
            't' : ival :=  9;
            'n' : ival := 10;
            'v' : ival := 11;
            'f' : ival := 12;
            'r' : ival := 13;
            Else ival := byte(s[1]);
          End;
          escaped := False;
          stuffit := 2;
        End
        Else
        Begin
          Case s[1] Of
            '\' : Begin
                    escaped := True;
                    stuffit := 0;
                  End;
            '?' : Begin
                    ival := 0;
                    stuffit := 3;
                  End;
            Else Begin
                   If s[1] = quote Then
                   Begin
                     quote := #0;
                     ignocase := False;
                     stuffit := 0;
                   End
                   Else
                   Begin
                     ival := byte(s[1]);
                     stuffit := 2;
                   End;
                 End;
          End;
        End;
      End;
      If stuffit >= 2 Then
      Begin
        buff[len] := ival;
        If stuffit = 3 Then maskbuff[len] := $0;
        nocase[len] := ignocase;
        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;
  Begin                                                        { getmatchpos }
    Delete(s,1,1);
    nega := False;
    If s[1] = '-' Then
    Begin
      nega := True;
      Delete(s,1,1);
    End;
    While (s <> '') And (UpCase(s[1]) In ['0'..'9','A'..'F']) Do
    Begin
      matchpos := 16*matchpos + hex2num(s[1]);
      Delete(s,1,1);
    End;
    If nega Then matchpos := testfsize - matchpos;
    If matchpos < 0 Then matchpos := 0;
    strip(s);
  End;                                                         { getmatchpos }

Begin
  getargs;
  gettestfile;
  openmagicfile;
  match := False;
  While Not (EoF(magicfile) Or match) Do
  Begin
    readln(magicfile,temp);
    If IOResult <> 0 Then
    Begin
      writeln('Error reading magic number file ',mname);
      Halt(5);
    End;
    strip(temp);
    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
      matchpos := 0;
      If temp[1] = '@' Then matchpos := getmatchpos(temp);
      masklen := 0;
      If temp[1] = '&' Then
      Begin
        Delete(temp,1,1);
        getsequence(temp,maskbuff,masklen,False);
        strip(temp);
      End;
      getsequence(temp,magic,magiclen,True);
      strip(temp);
      For i := masklen To Pred(magiclen) Do maskbuff[i] := $FF;
      If matchpos+magiclen <= examlen Then
      Begin
        buffno := 0;
        examstart := matchpos;
      End
      Else
      Begin
        buffno := 1;
        If (matchpos < pos2) Or (matchpos+magiclen > pos2+examlen) Then
        Begin
          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);
        End;
        examstart := matchpos - pos2;
      End;
      If examlen >= magiclen Then
      Begin
        match := True;
        i := 0;
        While match And (i < magiclen) Do
        Begin
          ctemp := char(translat[exambuff[buffno,i+examstart]]);
          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;
  End;
  Close(magicfile);
  Close(testfile);
  If Not match Then temp := 'unknown';
  writeln(fname,': ',temp);
End.