(* TURBO PASCAL 4.0 version of MSBPCT                      *)
(*                                                         *)
(* Author: Helmut Waelder (ZRWA001 at DTUZDV1.BITNET)      *)
(*         Zentrum fuer Datenverarbeitung                  *)
(*         Brunnenstr. 27                                  *)
(*         D-7400 Tuebingen                                *)
(*                                                         *)
(* Version 1.1 of 87/11/22 - modified to check for         *)
(*        corrupted input (optional) and to allow          *)
(*        output file name overriding                      *)
(*        Gisbert W.Selke (RECK@DBNUAMA1.BITNET)           *)
(*        Wissenschaftliches Institut der Ortskrankenkassen*)
(*        Kortrijker Strasse 1                             *)
(*        D-5300 Bonn 1                                    *)
(*        West Germany                                     *)
(* Version 1.2 of 88/02/10 - modified for Turbo Pascal 4.0 *)
(*                                                         *)
(* Decodes the mskermit.boo file about three times as fast *)
(* as the C version (if checking is not ON)                *)

(*$S-*)     (* Stack checking off *)
(*$R-*)     (* Range checking off *)
(*$B-*)     (* Boolean complete evaluation off *)
(*$I+*)     (* I/O checking on *)
(*$N-*)     (* No numeric coprocessor *)
(*$M 65500,16384,16384*)  (* Reduce maximum heap *)

program msbpct;

uses crt;

const repbyte  : byte = 78; (* ord('tilde') - ord('0') *)
      zerobyte : byte = 48;
      zerochar        = '0';
      smallo          = 'o';
      tilde           = '~';
      nullchar : char = #0;
      maxlinlength    = 76;
      bufsize         = 31500;
      defaultinname   = 'MSTIBM.BOO';
      defaultoutname  = 'MSTIBM.EXE';
      defaultext      = '.BOO';

type buftype = array (.1..bufsize.) of byte;

var a, b, c, d :  byte;
    i, index, linno, linlength : integer;
    isend, ok, relax : boolean;
    infilename, outfilename, originalname : string(.63.);
                                         (* maximum path length in DOS *)
    line : string(.132.);
    inbuffer, outbuffer : buftype;
    infile, outfile : text;

 function getbyte(mode : integer) : byte;
  (* get one proper character from input stream and decode it *)
  var c  : char;
      ok : boolean;

   procedure errmsg(errmode : integer);
   (* output various error messages *)
   begin
    case errmode of
     0 : writeln('Improper character #',ord(c),
                 ' at line/column ',linno,'/',index);
     1 : writeln('Improper null repeat count #',ord(c),
                 ' at line/column ',linno,'/',index);
     2 : writeln('Input line #',linno,' too long');
    end;
   end;  (* errmsg *)

  begin  (* getbyte *)
   repeat  (* until proper character or eof *)
    c := zerochar;
    inc(index);
    while (index > linlength) and (not isend) do
     begin  (* get new input line *)
      inc(linno);
      if lo(linno) = 0 then write(chr(13),'Line ',linno);
      isend := eof(infile);
      if not isend then readln(infile,line);
      linlength := length(line);
      if linlength > maxlinlength then errmsg(2);
      index := 1;
     end;  (* get new input line *)
    if not isend then c := line(.index.);
    ok := isend or relax;
    if not ok then
     begin  (* be suspicious *)
    if c in (.zerochar..smallo.) then ok := true (* vanilla character *)
     else  (* depending on context *)
     begin  (* be suspicious *)
      if c <> ' ' then
       case mode of
        0 : errmsg(0);  (* within ordinary chunk *)
        1 : if c = tilde then ok := true  (* first byte of chunk... *)
                         else errmsg(0);  (* ... may also be tilde  *)
        2 : if c in (.smallo..tilde.) then ok := true  (* repeat count *)
                                      else errmsg(1);
       end;  (* depending on context *)
      end;
     end;  (* be suspicious *)
   until ok;  (* until proper character or eof *)
   getbyte := ord(c) - zerobyte;
  end;  (* getbyte *)

 procedure prepare;
 (* get input and output file names; open files *)
  var ch : char;
      option : string(.10.);
      ctemp  : string(.63.);
  begin
   if paramcount > 3 then
    Begin  (* argument number error *)
     writeln('Wrong number of parameters.');
     writeln('Usage:  MSBPCT (<input file name> (<output file name>)) (/C)');
     halt(1);
    end;  (* argument number error *)
   if paramcount >= 1 then infilename := paramstr(1)
                      else infilename := defaultinname;
   if pos('.',infilename) = 0 then infilename := infilename + defaultext;
   assign(infile,infilename);
   settextbuf(infile,inbuffer);
   (*$I-*) reset(infile); (*$I+*)
   if IOResult <> 0 then
    begin
     writeln(infilename,' not found');
     halt(1);
    end;
   readln(infile,originalname);
   while ((length(originalname) > 0) and (originalname(.1.) = ' ')) do
                                            delete(originalname,1,1);
   if pos(' ',originalname) > 0 then
                           delete(originalname,pos(' ',originalname),999);
   if length(originalname) = 0 then
    begin
     writeln('Original file name missing - replaced by ',defaultoutname);
     originalname := defaultoutname;
    end;
   outfilename := originalname;
   option := '';
   if paramcount >= 2 then
    begin  (* more parameters *)
     if paramcount > 2 then
      begin  (* still more parameters *)
       outfilename := paramstr(2);
       option := copy(paramstr(3),1,10);
      end  (* still more parameters *)
      else
       begin  (* two parameters *)
        ctemp := paramstr(2);
        if ctemp(.1.) = '/' then option := copy(ctemp,1,10)
                          else outfilename := ctemp;
      end; (* two parameters *)
    end; (* more parameters *)
   relax := true;
   if option <> '' then
    begin
     if (option = '/C') or (option = '/c') then relax := false
                    else writeln('Only option available is [/C[')
    end;
   assign(outfile,outfilename);
   settextbuf(outfile,outbuffer);
   (*$I-*) reset(outfile); (*$I+*)
   if IOResult = 0 then
    begin  (* overwrite existing file? *)
     write('Output file ',outfilename,
           ' already exists. Continue (y/n)? ');
     repeat
      ch := readkey;
      ch := upcase(ch);
      until ch in (.'N','0','J','Y','1'.);
     writeln;
     if ch in (.'N','0'.) then halt(1);
    end;  (* overwrite existing file? *)
   (*$I-*) rewrite(outfile); (*$I+*)
   if IOResult<>0 then
    begin
     writeln('Couldn''t open ',outfilename);
     halt(1);
    end;
   checkbreak := false;
  end; (* prepare *)

Begin  (* main *)
 writeln('MSBPCT 1.2');
 prepare;
 writeln('Decoding ',infilename,', creating ',outfilename);
 if outfilename <> originalname then write(' (Original name was ',
                                            originalname,')');
 if not relax then write(' (checking integrity)');
 writeln;
 isend := false;
 linlength := 0;
 index := succ(maxlinlength);
 linno := 1;
 while not isend do
  begin  (* get all chunks *)
   a := getbyte(1);
   if a = repbyte then
    begin  (* null repeating *)
     b := getbyte(2);
     for i:=1 to b do write(outfile,nullchar);
    end  (* null repeating *)
    else
    begin  (* ordinary chunk *)
     b := getbyte(0);
     c := getbyte(0);
     d := getbyte(0);
     write(outfile,chr((a shl 2) or (b shr 4)));
     write(outfile,chr((b shl 4) or (c shr 2)));
     write(outfile,chr((c shl 6) or d));
    end;  (* ordinary chunk *)
  end;  (* get all chunks *)
 (* write(outfile,#26);  *) (* there is no need to append a ctrl-z *)
 flush(outfile);
 close(infile);
 close(outfile);
 writeln(chr(13),linno,' lines read.');
end. (* main *)