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

Pascal/Delphi Source File | 1990-08-12 | 16.8 KB | 439 lines

Program xferxlat;
{ Transfer a XLAT translation table between COM and table files.             }
{ FreeWare by TapirSoft Gisbert W.Selke, Aug 1990                            }

{$UNDEF  DEBUG }        { DEFINE while debugging }

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

  Const progname  = 'XferXlat';
        version   = '1.1';
        copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Aug 1990';
        idstring10= 'XLAT10';
        idstring11= 'XLAT11';
        idlength  = Length(idstring10);
        hexnibble : string[16] = '0123456789ABCDEF';
        digits    : string[10] = '0123456789';

  Const fbufsize = 4096;
        width    = 18;

  Type tabletype = Array [byte] Of byte;
       fbuftype  = Array [1..fbufsize] Of byte;

  Var fnamep, fnamet, fnameo : string;
      xlat  : File;
      tabf  : text;
      fbuf  : fbuftype;
      fsize : word;
      transtype : byte;
      doinvert : boolean;
      descript, intername : string;
      tstart, tabstart, interstart : word;
      desclen  : byte;
      xlatid   : byte;
      table    : tabletype;
      exitsave : Pointer;

  Function LoCase(ch : char) : char;
  { make characters lower case; national special characters, too!            }
    Inline($58/$3C/$41/$72/$39/$3C/$5A/$76/$33/$3C/$8E/$75/$02/$B0/$84
    /$3C/$99/$75/$02/$B0/$94/$3C/$9A/$75/$02/$B0/$81
    /$3C/$80/$75/$02/$B0/$87/$3C/$8F/$75/$02/$B0/$86
    /$3C/$90/$75/$02/$B0/$82/$3C/$92/$75/$02/$B0/$91
    /$3C/$A5/$75/$02/$B0/$A4/$EB/03/90/$04/$20);

  Function hexbyte(b : byte) : string;
  { convert a byte to a string                                               }
  Begin                                                            { hexbyte }
    hexbyte := hexnibble[Succ(b ShR 4)] + hexnibble[Succ(b And $0F)];
  End;                                                             { hexbtye }

  Procedure abort(msg : string; errcode : byte);
  { show message and die                                                     }
  Begin                                                              { abort }
    writeln(msg);
    Halt(errcode);
  End;                                                               { abort }

  Procedure invert;
  { invert a translation table                                               }
    Var temp : tabletype;
        i : byte;
  Begin                                                             { invert }
    For i :=   0     To   255 Do temp[i] := 0;
    For i := 255 DownTo     0 Do temp[table[i]] := i;
    table := temp;
  End;                                                              { invert }

  Procedure loadcom(fname : string; loadcomplete : boolean);
  { load a COM file. if not loadcomplete, then load table data only          }

    Const proginfoptr = 4;

    Var i, xfsize, xinterstart, xtstart, xtabstart : word;
        xdesclen : byte;
        temp : string;
        fbuf1 : fbuftype;

  Begin                                                            { loadcom }
    i := FileMode;
    FileMode := 0;
    Assign(xlat,fname);
    {$I- }
    Reset(xlat,1);
    FileMode := i;
    If IOResult <> 0 Then abort('File ' + fname + ' not found',2);
    BlockRead(xlat,fbuf1,fbufsize,xfsize);
    Close(xlat);
    {$I+ }
    If IOResult <> 0 Then abort('Error reading file ' + fname,3);
    i := fbuf1[proginfoptr] + 1;
    temp[0] := Chr(idlength);
    Move(fbuf1[i],temp[1],idlength);
    xlatid := 0;
    If temp = idstring10 Then xlatid := 10;
    If temp = idstring11 Then xlatid := 11;
    If xlatid = 0 Then abort('Unknown programme version ' + temp + ' in ' +
                             fname,4);
    Move(fbuf1[i+8],xinterstart,2);
    If xinterstart >= xfsize Then abort('File ' + fname +
                                        ' has invalid format',5);
    Inc(xinterstart);
    xtstart := Succ(fbuf1[i+6]);
    xdesclen := fbuf1[i+7];
    Move(fbuf1[i+10],xtabstart,2);
    Inc(xtabstart);
    Move(fbuf1[xtstart],descript[1],xdesclen);
    Move(fbuf1[xtabstart],table,256);
    Move(fbuf1[xinterstart],intername[1],8);
    intername[0] := #8;
    If loadcomplete Then
    Begin
      fbuf        := fbuf1;
      fsize       := xfsize;
      interstart  := xinterstart;
      tstart      := xtstart;
      tabstart    := xtabstart;
      desclen     := xdesclen;
      descript[0] := Chr(desclen);
    End
    Else
    Begin
      For i := Succ(xdesclen) To desclen Do descript[i] := ' ';
    End;
  End;                                                             { loadcom }

  Procedure savecom(fname : string);
  { save a translation table as a COM file                                   }
    Var iwrite : word;
  Begin                                                            { savecom }
    intername := fname;
    While (intername <> '') And (Pos(':',intername) > 0) Do
                                  Delete(intername,1,Pos(':',intername));
    While (intername <> '') And (Pos('\',intername) > 0) Do
                                  Delete(intername,1,Pos('\',intername));
    While (intername <> '') And (Pos('.',intername) > 0) Do
                                  Delete(intername,Pos('.',intername),255);
    While Length(intername) < 8 Do intername := intername + ' ';
    {$I- }
    Assign(xlat,fname);
    Rewrite(xlat,1);
    If IOResult <> 0 Then abort('Cannot open ' + fname + ' for output',10);
    Move(descript[1],fbuf[tstart],desclen);
    Move(table,fbuf[tabstart],256);
    Move(intername[1],fbuf[interstart],8);
    BlockWrite(xlat,fbuf,fsize,iwrite);
    If iwrite <> fsize Then abort('Error writing file ' + fname,11);
    Close(xlat);
    {$I+ }
  End;                                                             { savecom }

  Procedure loadtable(fname : string);
  { load a translation table from an ASCII table file                        }

    Var i : byte;
        tab1 : tabletype;
        descript1, lin, cmd, froms, tos, tname : string;
        fromval, toval : byte;
        ok : boolean;

    Function gettok(s : string; Var ptr : byte) : string;
    { returns next token from s, or ''                                       }
      Var beg : byte;
    Begin                                                           { gettok }
      While (ptr <= Length(s)) And ((s[ptr] = ' ') Or (s[ptr] = #9)) Do
                                                                     Inc(ptr);
      beg := ptr;
      While (ptr <= Length(s)) And (s[ptr] <> ' ') And (s[ptr] <> #9) Do
      Begin
        s[ptr] := UpCase(s[ptr]);
        Inc(ptr);
      End;
      gettok := Copy(s,beg,ptr-beg);
    End;                                                            { gettok }

    Function decoval(s : string; Var ok : boolean) : byte;
    { decodes a decimal or hexadecimal (prefixed by 'x') value               }
      Var i1, i2, num : byte;
    Begin                                                          { decoval }
      num := 0;
      ok := False;
      If s <> '' Then
      Begin
        If (s[1] = 'X') And (Length(s) >= 1) And (Length(s) <= 3) Then
        Begin
          If Length(s) = 2 Then
          Begin
            s[1] := '0';
            i2 := 1;
          End
            Else i2 := 2;
          i1 := Pos(s[i2],hexnibble);
          i2 := Pos(s[Succ(i2)],hexnibble);
          ok := (i1 > 0) And (i2 > 0);
          If ok Then num := Pred(i1) ShL 4 + Pred(i2);
        End
        Else
        Begin
          For i2 := 1 To Length(s) Do
          Begin
            i1 := Pos(s[i2],digits);
            ok := ok And (i1 > 0);
            If ok Then
            Begin
              If 10*word(num)+ i1 <= 256 Then num := 10*num + Pred(i1);
            End;
          End;
        End;
      End;
      decoval := num;
    End;                                                           { decoval }

  Begin                                                          { loadtable }
    i := FileMode;
    FileMode := 0;
    Assign(tabf,fname);
    {$I- }
    Reset(tabf);
    FileMode := i;
    If IOResult <> 0 Then abort('File ' + fname + ' not found',6);
    descript1 := '';
    For i := 0 To 255 Do tab1[i] := i;
    While Not EoF(tabf) Do
    Begin
      readln(tabf,lin);
      If Pos(';',lin) > 0 Then Delete(lin,Pos(';',lin),255);
      While (lin <> '') And ((lin[1] = ' ') Or (lin[1] = #9)) Do
                                                           Delete(lin,1,1);
      i := 1;
      cmd := gettok(lin,i);
      If cmd = '' Then cmd := ' ';
      If Length(cmd) > 1 Then cmd := '?';
      Case UpCase(cmd[1]) Of
        'V' : Begin { version string }
                If (gettok(lin,i) <> idstring10) And
                   (gettok(lin,i) <> idstring11) Then abort('Translation ' +
                                     'table version must be ' + idstring10 +
                                     ' or ' + idstring11,7);
              End;
        'D' : Begin { description }
                descript1 := Copy(lin,i,255);
                While (descript1 <> '') And ((descript1[1] = ' ') Or
                       (descript1[1] = #9)) Do Delete(descript1,1,1);
                While (descript1 <> '') And
                      ((descript1[Length(descript1)] = ' ')
                        Or (descript1[Length(descript1)] = #9))
                      Do Delete(descript1,Length(descript1),1);
                If Length(descript1) > desclen Then
                  Delete(descript1,Succ(desclen),255);
                While Length(descript1) < desclen Do
                                              descript1 := descript1 + ' ';
              End;
        'T' : Begin { translation pair }
                froms := gettok(lin,i);
                tos   := gettok(lin,i);
                ok := (Length(froms) >= 1) And (Length(froms) <= 3) And
                      (Length(tos) >= 1)   And (Length(tos) <= 3);
                If ok Then
                Begin
                  fromval := decoval(froms,ok);
                  If ok Then toval := decoval(tos,ok);
                  If ok then tab1[fromval] := toval;
                End;
                If Not ok Then abort('Illegal translation directive ' +
                                      Copy(lin,1,20) + ' in file ' + fname,8);
              End;
        ' ' : ; { ignore empty lines }
        Else abort('Illegal directive ' + Copy(lin,1,20) + ' in file ' +
                   fname,9);
      End;
    End;
    Close(tabf);
    intername := fname;
    descript := descript1;
    table := tab1;
  End;                                                           { loadtable }

  Procedure savetable(fname : string);
  { save a translation table to an ASCII table file                          }
    Var i : byte;
  Begin                                                          { savetable }
    intername := fname;
    While (intername <> '') And (Pos(':',intername) > 0) Do
                                  Delete(intername,1,Pos(':',intername));
    While (intername <> '') And (Pos('\',intername) > 0) Do
                                  Delete(intername,1,Pos('\',intername));
    While (intername <> '') And (Pos('.',intername) > 0) Do
                                  Delete(intername,Pos('.',intername),255);
    While Length(intername) < 8 Do intername := intername + ' ';
    Assign(tabf,fname);
    {$I- }
    Rewrite(tabf);
    If IOResult <> 0 Then abort('Cannot open ' + fname + ' for output',12);
    writeln(tabf,'; Translation table for use with ConfXLat');
    writeln(tabf,'; Everything after a '';'' is a comment.');
    writeln(tabf,'; Values are decimal by default, and hexadecimal if ',
                 'preceded by ''x''.');
    writeln(tabf,'V ',idstring10,' ':20,'; version');
    writeln(tabf,'D ',descript,'   ; description (max length: ',desclen,
                 ')');
    writeln(tabf,'; Translation table follows.');
    writeln(tabf,'; Start each row with a ''T''; first value is mapped to ',
                 'second value.');
    writeln(tabf,'; Missing values will be mapped to themselves.');
    For i := 0 To 255 Do writeln(tabf,'T  x',hexbyte(i):2,
                                      ' x',hexbyte(table[i]):2);
    writeln(tabf,'; End of translation table');
    If IOResult <> 0 Then abort('Error writing file ' + fname,12);
    Close(tabf);
    {$I+ }
  End;                                                           { savetable }

  Procedure usage;
  { show usage info                                                          }
  Begin                                                              { usage }
    writeln;
    writeln('Transfers Xlat translation tables between COM files and tables');
    writeln('Choose one of four transfer types:');
    writeln('To build a filter/driver using a translation table file:');
    writeln('    xferxlat  xlat1.com xlat2.tbl xlat3.com  [/i]');
    writeln('To build a driver from a filter or vice versa:');
    writeln('    xferxlat  xlat1.com xlat2.com xlat3.com  [/i]');
    writeln('To build a translation table file from a filter/driver:');
    writeln('    xferxlat  xlat1.com xlat3.tbl            [/i]');
    writeln('To build a filter from a filter or a driver from a driver:');
    writeln('    xferxlat  xlat1.com xlat3.com            [/i]');
    writeln('where xlat1 determines the flavour (filter/driver) of xlat3');
    writeln('and   xlat2 determines the contents of the translation.');
    writeln('The optional /i requests inversion of the table.');
    writeln('For the first and third arguments, the .COM extension is ',
            'optional;');
    writeln('for the second argument, the extension determines the type of ',
            'transfer.');
    writeln;
    Halt(1);
  End;                                                               { usage }

  Procedure parseargs;
  { parse command line; determine what sort of translation we want           }

    Const comext = '.com';

    Var temp : string;
        i, k : byte;

    Function iscom(fname : string) : boolean;
    { does fname have .COM extension?                                        }
    Begin                                                            { iscom }
      iscom := Pos(comext,fname) > 0;
    End;                                                             { iscom }

  Begin                                                          { parseargs }
    fnamep := '';
    fnamet := '';
    fnameo := '';
    doinvert := False;
    For i := 1 To ParamCount Do
    Begin
      temp := ParamStr(i);
      For k := 1 To Length(temp) Do temp[k] := LoCase(temp[k]);
      If (Length(temp) = 2) And (temp[1] In ['-','/']) And (temp[2] = 'i') Then
      Begin
        If doinvert Then usage;
        doinvert := True;
      End
      Else
      Begin
        If fnamep = '' Then
        Begin
          If Not iscom(temp) Then temp := temp + comext;
          fnamep := temp;
        End
        Else
        Begin
          If fnamet = '' Then fnamet := temp
          Else
          Begin
            If fnameo = '' Then
            Begin
              If Not iscom(temp) Then temp := temp + comext;
              fnameo := temp;
            End
            Else usage;
          End;
        End;
      End;
    End;
    If fnamet = '' Then usage;
    If fnameo = '' Then
    Begin
      fnameo := fnamet;
      fnamet := '';
      If iscom(fnameo) Then transtype := 4
                       Else transtype := 3;
    End
    Else
    Begin
      If iscom(fnamet) Then transtype := 2
                       Else transtype := 1;
    End;
  End;                                                           { parseargs }

  {$F+ } Procedure myexit; {$F- }
  { exit procedure                                                           }
  Begin                                                             { myexit }
    ExitProc := exitsave;
    writeln(progname,' ',version,' - translation filter/driver transfer');
    writeln(copyright);
    writeln;
    writeln('This programme, and the filters, resident drivers, and tables,');
    writeln('may be used and copied freely.');
    writeln('However, it comes without any guarantees;');
    writeln('the whole risk of its use lies with the user.');
  End;                                                              { myexit }

Begin                                                                 { main }
  exitsave := ExitProc;
  ExitProc := @myexit;
  parseargs;
  desclen := 0;
  loadcom(fnamep,True);
  If transtype = 1 Then loadtable(fnamet);
  If transtype = 2 Then loadcom(fnamet,False);
  If doinvert Then
  Begin
    invert;
    descript[Pred(desclen)] := '/';
    descript[desclen] := 'i';
  End;
  If transtype = 3 Then savetable(fnameo)
                   Else savecom(fnameo);
End.