(* TURBO pascal version of MSBMKB                            *)
(*                                                           *)
(* Author: Gisbert W.Selke (RECK@DBNUAMA1.BITNET)            *)
(*         Wissenschaftliches Institut der Ortskrankenkassen *)
(*         Kortrijker Strasse 1                              *)
(*         D-5300 Bonn 1                                     *)
(*         West Germany                                      *)
(*         10 February 1988                                  *)
(*         RECK@DBNUAMA1.BITNET                              *)
(*                                                           *)
(*  Produces boo-encoding of a binary file for transfer over *)
(*  data links. Beware of EBCDIC <-> ASCII gremlins, however!*)
(*                                                           *)
(*  Version 1.2: change for Turbo-Pascal 4.0                 *)
(*                                                           *)

(*$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 msbmkb;

uses crt;

const repchar  : char = '~';
      nullbyte : byte = $00;
      b2       : byte = $03;
      b4       : byte = $0F;
      b6       : byte = $3F;
      blocksize       = 128;
      offset          = 48;  (* ord('0') *)
      maxrep          = 78;
      bufsize         = 32000;
      maxlinlength    = 76;
      defaultext      = '.BOO';

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

var a, b, c :  byte;
    bytect, buffct, restbytes, maxblocks, bbufsize, linlength, repct : integer;
    fs, rin, rout : longint;
    reff : real;
    isend,preend : boolean;
    infilename, outfilename, sname : string(.63.);
                                         (* maximum path length in DOS *)
    buffer, outbuffer : buftype;
    infile  : file;
    outfile : text;

 function getbyte : byte;
  (* get one byte from input stream; mark eof and yield 0 afterwards *)
   var ires : word;
  begin  (* getbyte *)
   if isend then
    begin  (* end of file *)
     getbyte := nullbyte;
     exit;
    end;  (* end of file *)
   if bytect >= bbufsize then
    begin  (* read next buffer *)
     if preend then
      begin  (* end of file *)
       getbyte := 0;
       isend := true;
       exit;
      end;  (* end of file *)
     blockread(infile,buffer,maxblocks,ires);
     if ires <> maxblocks then
      begin  (* last buffer! *)
       preend := true;
       bbufsize := restbytes;
      end;   (* last buffer! *)
     bytect := 0;
     inc(buffct);
     write(chr(13),'Buffer ',buffct);
    end;  (* read next buffer *)
   inc(bytect);
   getbyte := buffer(.bytect.);
  end;  (* getbyte *)

 procedure prepare;
 (* get input and output file names; open files; get input file size *)

   procedure getnames;
   (* get input and output file names from command line *)
    var i : integer;
   begin  (* getnames *)
    if not (paramcount in (.1..2.)) then
     Begin  (* argument number error *)
      writeln('Wrong number of parameters.');
      writeln('Usage: MSBMKB <input file name> (<output file name>)');
      halt(1);
     end;  (* argument number error *)
    infilename := paramstr(1);
    for i := 1 to length(infilename) do infilename(.i.) :=
                                        UpCase(infilename(.i.));
    sname := infilename;
    while pos(':',sname) <> 0 do delete(sname,1,pos(':',sname));
    while pos('\',sname) <> 0 do delete(sname,1,pos('\',sname));
    outfilename := sname;
    if pos('.',outfilename) <> 0 then delete(outfilename,
                                            pos('.',outfilename),999);
    outfilename := outfilename + defaultext;
    if outfilename = infilename then outfilename(.length(infilename).) :=
                                succ(outfilename(.length(infilename).));
    if paramcount = 2 then outfilename := paramstr(2);
    for i := 1 to length(outfilename) do outfilename(.i.) :=
                                        UpCase(outfilename(.i.));
   end;  (* getnames *)

   procedure openfiles;
   (* open input and output files; abort if error *)
    var ch : char;
   begin  (* openfiles *)
    assign(infile,infilename);
    (*$I-*) reset(infile,blocksize); (*$I+*)
    if IOResult <> 0 then
     begin
      writeln('Can''t find ',infilename);
      halt(1);
     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('Can''t open output file ',outfilename);
      halt(1);
     end;
   end;  (* openfiles *)

   procedure getsize;
   (* get size of input file; initialize certain variables *)
    var dummyfile : file of byte;
   begin  (* getsize *)
    assign(dummyfile,infilename);
    reset(dummyfile);
    fs := filesize(dummyfile);
    close(dummyfile);
    restbytes := fs - (pred(fs) div bufsize) * bufsize;
    buffct := 0;
    bbufsize := bufsize;
    bytect := succ(bbufsize);
    maxblocks := bufsize div blocksize;
  end;  (* getsize *)

  begin  (* prepare *)
   getnames;
   openfiles;
   getsize;
   checkbreak := false;
  end; (* prepare *)

begin  (* main *)
 writeln('MSBPCT 1.2');
 prepare;
 writeln('Encoding ',infilename,' to ',outfilename);
 writeln(outfile,sname);
 isend  := false;
 preend := false;
 linlength := 0;
 rout := length(sname) + 2;
 a := getbyte;
 while not isend do
  begin  (* get all chunks *)
   b := getbyte;
   if (a=0) and (b=0) then
    begin  (* repeatnull *)
     repct := 1;
     repeat
       inc(repct);
       a := getbyte;
      until isend or (a <> nullbyte) or (repct >= maxrep);
     if linlength+2 > maxlinlength then
      begin  (* finish line *)
       writeln(outfile);
       rout := rout + linlength + 2;
       linlength := 0;
      end;  (* finish line *)
     write(outfile,repchar,chr(repct+offset));
     inc(linlength,2);
    end  (* repeatnull *)  else
    begin  (* ordinary chunk *)
     c := getbyte;
     if linlength+4 > maxlinlength then
      begin  (* finish line *)
       writeln(outfile);
       rout := rout + linlength + 2;
       linlength := 0;
      end;  (* finish line *)
     write(outfile,chr((a shr 2) + offset),
                   chr((((a and b2) shl 4) or (b shr 4)) + offset),
                   chr((((b and b4) shl 2) or (c shr 6)) + offset),
                   chr((c and b6) + offset));
     inc(linlength,4);
     a := getbyte;
    end;  (* ordinary chunk *)
  end;  (* get all chunks *)
 writeln(outfile);
 rout := rout + linlength + 2;
 flush(outfile);
 close(infile);
 close(outfile);
 rin := longint(pred(buffct))*bufsize + bytect;
 reff := 100.0 * rin / rout;
 writeln(chr(13),rin:0,' bytes in, ',rout:0,
         ' bytes out; efficiency: ',reff:0:1,'%');
end. (* main *)