home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / mskermit / msbpct.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  8KB  |  221 lines
  1. (* TURBO PASCAL 4.0 version of MSBPCT                      *)
  2. (*                                                         *)
  3. (* Author: Helmut Waelder (ZRWA001 at DTUZDV1.BITNET)      *)
  4. (*         Zentrum fuer Datenverarbeitung                  *)
  5. (*         Brunnenstr. 27                                  *)
  6. (*         D-7400 Tuebingen                                *)
  7. (*                                                         *)
  8. (* Version 1.1 of 87/11/22 - modified to check for         *)
  9. (*        corrupted input (optional) and to allow          *)
  10. (*        output file name overriding                      *)
  11. (*        Gisbert W.Selke (RECK@DBNUAMA1.BITNET)           *)
  12. (*        Wissenschaftliches Institut der Ortskrankenkassen*)
  13. (*        Kortrijker Strasse 1                             *)
  14. (*        D-5300 Bonn 1                                    *)
  15. (*        West Germany                                     *)
  16. (* Version 1.2 of 88/02/10 - modified for Turbo Pascal 4.0 *)
  17. (*                                                         *)
  18. (* Decodes the mskermit.boo file about three times as fast *)
  19. (* as the C version (if checking is not ON)                *)
  20.  
  21. (*$S-*)     (* Stack checking off *)
  22. (*$R-*)     (* Range checking off *)
  23. (*$B-*)     (* Boolean complete evaluation off *)
  24. (*$I+*)     (* I/O checking on *)
  25. (*$N-*)     (* No numeric coprocessor *)
  26. (*$M 65500,16384,16384*)  (* Reduce maximum heap *)
  27.  
  28. program msbpct;
  29.  
  30. uses crt;
  31.  
  32. const repbyte  : byte = 78; (* ord('tilde') - ord('0') *)
  33.       zerobyte : byte = 48;
  34.       zerochar        = '0';
  35.       smallo          = 'o';
  36.       tilde           = '~';
  37.       nullchar : char = #0;
  38.       maxlinlength    = 76;
  39.       bufsize         = 31500;
  40.       defaultinname   = 'MSTIBM.BOO';
  41.       defaultoutname  = 'MSTIBM.EXE';
  42.       defaultext      = '.BOO';
  43.  
  44. type buftype = array (.1..bufsize.) of byte;
  45.  
  46. var a, b, c, d :  byte;
  47.     i, index, linno, linlength : integer;
  48.     isend, ok, relax : boolean;
  49.     infilename, outfilename, originalname : string(.63.);
  50.                                          (* maximum path length in DOS *)
  51.     line : string(.132.);
  52.     inbuffer, outbuffer : buftype;
  53.     infile, outfile : text;
  54.  
  55.  function getbyte(mode : integer) : byte;
  56.   (* get one proper character from input stream and decode it *)
  57.   var c  : char;
  58.       ok : boolean;
  59.  
  60.    procedure errmsg(errmode : integer);
  61.    (* output various error messages *)
  62.    begin
  63.     case errmode of
  64.      0 : writeln('Improper character #',ord(c),
  65.                  ' at line/column ',linno,'/',index);
  66.      1 : writeln('Improper null repeat count #',ord(c),
  67.                  ' at line/column ',linno,'/',index);
  68.      2 : writeln('Input line #',linno,' too long');
  69.     end;
  70.    end;  (* errmsg *)
  71.  
  72.   begin  (* getbyte *)
  73.    repeat  (* until proper character or eof *)
  74.     c := zerochar;
  75.     inc(index);
  76.     while (index > linlength) and (not isend) do
  77.      begin  (* get new input line *)
  78.       inc(linno);
  79.       if lo(linno) = 0 then write(chr(13),'Line ',linno);
  80.       isend := eof(infile);
  81.       if not isend then readln(infile,line);
  82.       linlength := length(line);
  83.       if linlength > maxlinlength then errmsg(2);
  84.       index := 1;
  85.      end;  (* get new input line *)
  86.     if not isend then c := line(.index.);
  87.     ok := isend or relax;
  88.     if not ok then
  89.      begin  (* be suspicious *)
  90.     if c in (.zerochar..smallo.) then ok := true (* vanilla character *)
  91.      else  (* depending on context *)
  92.      begin  (* be suspicious *)
  93.       if c <> ' ' then
  94.        case mode of
  95.         0 : errmsg(0);  (* within ordinary chunk *)
  96.         1 : if c = tilde then ok := true  (* first byte of chunk... *)
  97.                          else errmsg(0);  (* ... may also be tilde  *)
  98.         2 : if c in (.smallo..tilde.) then ok := true  (* repeat count *)
  99.                                       else errmsg(1);
  100.        end;  (* depending on context *)
  101.       end;
  102.      end;  (* be suspicious *)
  103.    until ok;  (* until proper character or eof *)
  104.    getbyte := ord(c) - zerobyte;
  105.   end;  (* getbyte *)
  106.  
  107.  procedure prepare;
  108.  (* get input and output file names; open files *)
  109.   var ch : char;
  110.       option : string(.10.);
  111.       ctemp  : string(.63.);
  112.   begin
  113.    if paramcount > 3 then
  114.     Begin  (* argument number error *)
  115.      writeln('Wrong number of parameters.');
  116.      writeln('Usage:  MSBPCT (<input file name> (<output file name>)) (/C)');
  117.      halt(1);
  118.     end;  (* argument number error *)
  119.    if paramcount >= 1 then infilename := paramstr(1)
  120.                       else infilename := defaultinname;
  121.    if pos('.',infilename) = 0 then infilename := infilename + defaultext;
  122.    assign(infile,infilename);
  123.    settextbuf(infile,inbuffer);
  124.    (*$I-*) reset(infile); (*$I+*)
  125.    if IOResult <> 0 then
  126.     begin
  127.      writeln(infilename,' not found');
  128.      halt(1);
  129.     end;
  130.    readln(infile,originalname);
  131.    while ((length(originalname) > 0) and (originalname(.1.) = ' ')) do
  132.                                             delete(originalname,1,1);
  133.    if pos(' ',originalname) > 0 then
  134.                            delete(originalname,pos(' ',originalname),999);
  135.    if length(originalname) = 0 then
  136.     begin
  137.      writeln('Original file name missing - replaced by ',defaultoutname);
  138.      originalname := defaultoutname;
  139.     end;
  140.    outfilename := originalname;
  141.    option := '';
  142.    if paramcount >= 2 then
  143.     begin  (* more parameters *)
  144.      if paramcount > 2 then
  145.       begin  (* still more parameters *)
  146.        outfilename := paramstr(2);
  147.        option := copy(paramstr(3),1,10);
  148.       end  (* still more parameters *)
  149.       else
  150.        begin  (* two parameters *)
  151.         ctemp := paramstr(2);
  152.         if ctemp(.1.) = '/' then option := copy(ctemp,1,10)
  153.                           else outfilename := ctemp;
  154.       end; (* two parameters *)
  155.     end; (* more parameters *)
  156.    relax := true;
  157.    if option <> '' then
  158.     begin
  159.      if (option = '/C') or (option = '/c') then relax := false
  160.                     else writeln('Only option available is [/C[')
  161.     end;
  162.    assign(outfile,outfilename);
  163.    settextbuf(outfile,outbuffer);
  164.    (*$I-*) reset(outfile); (*$I+*)
  165.    if IOResult = 0 then
  166.     begin  (* overwrite existing file? *)
  167.      write('Output file ',outfilename,
  168.            ' already exists. Continue (y/n)? ');
  169.      repeat
  170.       ch := readkey;
  171.       ch := upcase(ch);
  172.       until ch in (.'N','0','J','Y','1'.);
  173.      writeln;
  174.      if ch in (.'N','0'.) then halt(1);
  175.     end;  (* overwrite existing file? *)
  176.    (*$I-*) rewrite(outfile); (*$I+*)
  177.    if IOResult<>0 then
  178.     begin
  179.      writeln('Couldn''t open ',outfilename);
  180.      halt(1);
  181.     end;
  182.    checkbreak := false;
  183.   end; (* prepare *)
  184.  
  185. Begin  (* main *)
  186.  writeln('MSBPCT 1.2');
  187.  prepare;
  188.  writeln('Decoding ',infilename,', creating ',outfilename);
  189.  if outfilename <> originalname then write(' (Original name was ',
  190.                                             originalname,')');
  191.  if not relax then write(' (checking integrity)');
  192.  writeln;
  193.  isend := false;
  194.  linlength := 0;
  195.  index := succ(maxlinlength);
  196.  linno := 1;
  197.  while not isend do
  198.   begin  (* get all chunks *)
  199.    a := getbyte(1);
  200.    if a = repbyte then
  201.     begin  (* null repeating *)
  202.      b := getbyte(2);
  203.      for i:=1 to b do write(outfile,nullchar);
  204.     end  (* null repeating *)
  205.     else
  206.     begin  (* ordinary chunk *)
  207.      b := getbyte(0);
  208.      c := getbyte(0);
  209.      d := getbyte(0);
  210.      write(outfile,chr((a shl 2) or (b shr 4)));
  211.      write(outfile,chr((b shl 4) or (c shr 2)));
  212.      write(outfile,chr((c shl 6) or d));
  213.     end;  (* ordinary chunk *)
  214.   end;  (* get all chunks *)
  215.  (* write(outfile,#26);  *) (* there is no need to append a ctrl-z *)
  216.  flush(outfile);
  217.  close(infile);
  218.  close(outfile);
  219.  writeln(chr(13),linno,' lines read.');
  220. end. (* main *)
  221.