(* TURBO pascal 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                                    *)
(*                                                         *)
(* Decodes the mskermit.boo file about three times as fast *)
(* as the C version (if checking is not ON)                *)

(*$c-,k-,d-*)
program msbpct;
const repbyte  : byte = 78; (* ord('tilde') - ord('0') *)
      zerobyte : byte = 48;
      zerochar        = '0';
      smallo          = 'o';
      tilde           = '~';
      nullchar : char = #0;
      maxlinlength    = 76;
      defaultinname   = 'MSKERMIT.BOO';
      defaultoutname  = 'MSTIBM.EXE';
      defaultext      = '.BOO';

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.);
    infile, outfile : text(.32000.);

 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;
    index := succ(index);
    while (index > linlength) and (not isend) do
     begin  (* get new input line *)
      linno := succ(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) and (c <> ' ');
    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.);
  begin
   if paramcount > 3 then
    Begin  (* argument number error *)
     writeln('Too many arguments. Usage:  MSBPCT <inputfile> ',
             '(<outfilename>) (/C)');
     halt(1);
    end;  (* argument error *)
   if paramcount = 0 then infilename:= defaultinname  (* if no argument *)
    else
    begin  (* get input file name *)
     infilename := paramstr(1);
     if pos('.',infilename) = 0 then infilename := infilename + defaultext;
    end; (* get input file name *)
   assign(infile,infilename);
   (*$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  (* more parameters *)
        if copy(paramstr(2),1,1) = '/' then option := copy(paramstr(2),1,10)
                                       else outfilename := paramstr(2);
       end;
     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);
   (*$I-*) reset(outfile); (*$I+*)
   if IOResult = 0 then
    begin  (* overwrite existing file? *)
     write('Outputfile ',outfilename,' already exists. Continue (y/n)? ');
     repeat
      read(kbd,ch);
      until ch in (.'N','n','Y','y'.);
     writeln;
     if ch in (.'N','n'.) then halt(1);
    end;  (* overwrite existing file? *)
   (*$I-*) rewrite(outfile); (*$I+*)
   if IOResult<>0 then
    begin
     writeln('Could not open ',outfilename);
     halt(1);
    end;
  end; (* prepare *)

Begin  (* main *)
 writeln('MSBPCT 1.1');
 prepare;
 write('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 := 99;
 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);
end. (* main *)
