home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / mskermit / msbmkb.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  7KB  |  224 lines
  1. (* TURBO pascal version of MSBMKB                            *)
  2. (*                                                           *)
  3. (* Author: Gisbert W.Selke (RECK@DBNUAMA1.BITNET)            *)
  4. (*         Wissenschaftliches Institut der Ortskrankenkassen *)
  5. (*         Kortrijker Strasse 1                              *)
  6. (*         D-5300 Bonn 1                                     *)
  7. (*         West Germany                                      *)
  8. (*         10 February 1988                                  *)
  9. (*         RECK@DBNUAMA1.BITNET                              *)
  10. (*                                                           *)
  11. (*  Produces boo-encoding of a binary file for transfer over *)
  12. (*  data links. Beware of EBCDIC <-> ASCII gremlins, however!*)
  13. (*                                                           *)
  14. (*  Version 1.2: change for Turbo-Pascal 4.0                 *)
  15. (*                                                           *)
  16.  
  17. (*$S-*)     (* stack checking off *)
  18. (*$R-*)     (* Range checking off *)
  19. (*$B-*)     (* Boolean complete evaluation off *)
  20. (*$I+*)     (* I/O checking on *)
  21. (*$N-*)     (* No numeric coprocessor *)
  22. (*$M 65500,16384,16384*)  (* Reduce maximum heap *)
  23.  
  24. program msbmkb;
  25.  
  26. uses crt;
  27.  
  28. const repchar  : char = '~';
  29.       nullbyte : byte = $00;
  30.       b2       : byte = $03;
  31.       b4       : byte = $0F;
  32.       b6       : byte = $3F;
  33.       blocksize       = 128;
  34.       offset          = 48;  (* ord('0') *)
  35.       maxrep          = 78;
  36.       bufsize         = 32000;
  37.       maxlinlength    = 76;
  38.       defaultext      = '.BOO';
  39.  
  40. type buftype = array (.1..bufsize.) of byte;
  41.  
  42. var a, b, c :  byte;
  43.     bytect, buffct, restbytes, maxblocks, bbufsize, linlength, repct : integer;
  44.     fs, rin, rout : longint;
  45.     reff : real;
  46.     isend,preend : boolean;
  47.     infilename, outfilename, sname : string(.63.);
  48.                                          (* maximum path length in DOS *)
  49.     buffer, outbuffer : buftype;
  50.     infile  : file;
  51.     outfile : text;
  52.  
  53.  function getbyte : byte;
  54.   (* get one byte from input stream; mark eof and yield 0 afterwards *)
  55.    var ires : word;
  56.   begin  (* getbyte *)
  57.    if isend then
  58.     begin  (* end of file *)
  59.      getbyte := nullbyte;
  60.      exit;
  61.     end;  (* end of file *)
  62.    if bytect >= bbufsize then
  63.     begin  (* read next buffer *)
  64.      if preend then
  65.       begin  (* end of file *)
  66.        getbyte := 0;
  67.        isend := true;
  68.        exit;
  69.       end;  (* end of file *)
  70.      blockread(infile,buffer,maxblocks,ires);
  71.      if ires <> maxblocks then
  72.       begin  (* last buffer! *)
  73.        preend := true;
  74.        bbufsize := restbytes;
  75.       end;   (* last buffer! *)
  76.      bytect := 0;
  77.      inc(buffct);
  78.      write(chr(13),'Buffer ',buffct);
  79.     end;  (* read next buffer *)
  80.    inc(bytect);
  81.    getbyte := buffer(.bytect.);
  82.   end;  (* getbyte *)
  83.  
  84.  procedure prepare;
  85.  (* get input and output file names; open files; get input file size *)
  86.  
  87.    procedure getnames;
  88.    (* get input and output file names from command line *)
  89.     var i : integer;
  90.    begin  (* getnames *)
  91.     if not (paramcount in (.1..2.)) then
  92.      Begin  (* argument number error *)
  93.       writeln('Wrong number of parameters.');
  94.       writeln('Usage: MSBMKB <input file name> (<output file name>)');
  95.       halt(1);
  96.      end;  (* argument number error *)
  97.     infilename := paramstr(1);
  98.     for i := 1 to length(infilename) do infilename(.i.) :=
  99.                                         UpCase(infilename(.i.));
  100.     sname := infilename;
  101.     while pos(':',sname) <> 0 do delete(sname,1,pos(':',sname));
  102.     while pos('\',sname) <> 0 do delete(sname,1,pos('\',sname));
  103.     outfilename := sname;
  104.     if pos('.',outfilename) <> 0 then delete(outfilename,
  105.                                             pos('.',outfilename),999);
  106.     outfilename := outfilename + defaultext;
  107.     if outfilename = infilename then outfilename(.length(infilename).) :=
  108.                                 succ(outfilename(.length(infilename).));
  109.     if paramcount = 2 then outfilename := paramstr(2);
  110.     for i := 1 to length(outfilename) do outfilename(.i.) :=
  111.                                         UpCase(outfilename(.i.));
  112.    end;  (* getnames *)
  113.  
  114.    procedure openfiles;
  115.    (* open input and output files; abort if error *)
  116.     var ch : char;
  117.    begin  (* openfiles *)
  118.     assign(infile,infilename);
  119.     (*$I-*) reset(infile,blocksize); (*$I+*)
  120.     if IOResult <> 0 then
  121.      begin
  122.       writeln('Can''t find ',infilename);
  123.       halt(1);
  124.      end;
  125.     assign(outfile,outfilename);
  126.     settextbuf(outfile,outbuffer);
  127.     (*$I-*) reset(outfile); (*$I+*)
  128.     if IOResult = 0 then
  129.      begin  (* overwrite existing file? *)
  130.       write('Output file ',outfilename,
  131.             ' already exists. Continue (y/n)? ');
  132.       repeat
  133.        ch := readkey;
  134.        ch := upcase(ch);
  135.        until ch in (.'N','0','J','Y','1'.);
  136.       writeln;
  137.       if ch in (.'N','0'.) then halt(1);
  138.      end;  (* overwrite existing file? *)
  139.     (*$I-*) rewrite(outfile); (*$I+*)
  140.     if IOResult<>0 then
  141.      begin
  142.       writeln('Can''t open output file ',outfilename);
  143.       halt(1);
  144.      end;
  145.    end;  (* openfiles *)
  146.  
  147.    procedure getsize;
  148.    (* get size of input file; initialize certain variables *)
  149.     var dummyfile : file of byte;
  150.    begin  (* getsize *)
  151.     assign(dummyfile,infilename);
  152.     reset(dummyfile);
  153.     fs := filesize(dummyfile);
  154.     close(dummyfile);
  155.     restbytes := fs - (pred(fs) div bufsize) * bufsize;
  156.     buffct := 0;
  157.     bbufsize := bufsize;
  158.     bytect := succ(bbufsize);
  159.     maxblocks := bufsize div blocksize;
  160.   end;  (* getsize *)
  161.  
  162.   begin  (* prepare *)
  163.    getnames;
  164.    openfiles;
  165.    getsize;
  166.    checkbreak := false;
  167.   end; (* prepare *)
  168.  
  169. begin  (* main *)
  170.  writeln('MSBPCT 1.2');
  171.  prepare;
  172.  writeln('Encoding ',infilename,' to ',outfilename);
  173.  writeln(outfile,sname);
  174.  isend  := false;
  175.  preend := false;
  176.  linlength := 0;
  177.  rout := length(sname) + 2;
  178.  a := getbyte;
  179.  while not isend do
  180.   begin  (* get all chunks *)
  181.    b := getbyte;
  182.    if (a=0) and (b=0) then
  183.     begin  (* repeatnull *)
  184.      repct := 1;
  185.      repeat
  186.        inc(repct);
  187.        a := getbyte;
  188.       until isend or (a <> nullbyte) or (repct >= maxrep);
  189.      if linlength+2 > maxlinlength then
  190.       begin  (* finish line *)
  191.        writeln(outfile);
  192.        rout := rout + linlength + 2;
  193.        linlength := 0;
  194.       end;  (* finish line *)
  195.      write(outfile,repchar,chr(repct+offset));
  196.      inc(linlength,2);
  197.     end  (* repeatnull *)  else
  198.     begin  (* ordinary chunk *)
  199.      c := getbyte;
  200.      if linlength+4 > maxlinlength then
  201.       begin  (* finish line *)
  202.        writeln(outfile);
  203.        rout := rout + linlength + 2;
  204.        linlength := 0;
  205.       end;  (* finish line *)
  206.      write(outfile,chr((a shr 2) + offset),
  207.                    chr((((a and b2) shl 4) or (b shr 4)) + offset),
  208.                    chr((((b and b4) shl 2) or (c shr 6)) + offset),
  209.                    chr((c and b6) + offset));
  210.      inc(linlength,4);
  211.      a := getbyte;
  212.     end;  (* ordinary chunk *)
  213.   end;  (* get all chunks *)
  214.  writeln(outfile);
  215.  rout := rout + linlength + 2;
  216.  flush(outfile);
  217.  close(infile);
  218.  close(outfile);
  219.  rin := longint(pred(buffct))*bufsize + bytect;
  220.  reff := 100.0 * rin / rout;
  221.  writeln(chr(13),rin:0,' bytes in, ',rout:0,
  222.          ' bytes out; efficiency: ',reff:0:1,'%');
  223. end. (* main *)
  224.