home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / filutl / msbpct.arc / MSBPCT.PAS < prev   
Pascal/Delphi Source File  |  1987-08-20  |  3KB  |  98 lines
  1. (* TURBO pascal 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.0 of 87/07/10                                 *)
  9. (*                                                         *)
  10. (* Decodes the mskermit.boo file about 2 times faster than *)
  11. (* the C version.                                          *)
  12.  
  13. (*$c-,k-,d-*)
  14. program msbpct;
  15. const nullchr = 78; (* ord('tilde') - ord('0') *)
  16. var a,b,c,d:byte;
  17.     ch:char;
  18.     i,index:integer;
  19.     rptcnt,len:integer;
  20.     infilename:string(.63.); (* maximum path length in DOS *)
  21.     outfilename:string(.12.);
  22.     line:string(.132.);
  23.     infile,outfile:text(.32000.);
  24. function fixchr(x:char):byte;
  25. begin
  26.   fixchr:=ord(x)-48; (* ord('0') *)
  27. end;
  28.  
  29. Begin
  30. If paramcount > 1 then
  31.  Begin
  32.   writeln('Too many arguments. Usage:  MSBPCT <inputfile> ');
  33.   halt(1);
  34.  end;
  35. if paramcount = 0 then infilename:='MSKERMIT.BOO'
  36.  else
  37.  begin
  38.   infilename:=paramstr(1);
  39.   if pos('.',infilename)=0 then infilename:=infilename+'.BOO';
  40.  end;
  41. assign(infile,infilename);
  42. (*$I-*) reset(infile); (*$I+*)
  43. if IOResult <> 0 then
  44.  begin
  45.   writeln(infilename,' not found.');
  46.   halt(1);
  47.  end;
  48. readln(infile,outfilename);
  49. assign(outfile,outfilename);
  50. (*$I-*) reset(outfile); (*$I+*)
  51. if IOResult=0 then
  52.  begin
  53.   write('Outputfile ',outfilename,' already exists. Continue (y/n)? ');
  54.   repeat
  55.    read(kbd,ch);
  56.    ch:=upcase(ch);
  57.   until ch in (.'N','Y'.);
  58.   writeln;
  59.   if ch = 'N' then halt(1);
  60.  end;
  61. (*$I-*) rewrite(outfile); (*$I+*)
  62. if IOResult<>0 then
  63.  begin
  64.   writeln('Could not open ',outfilename);
  65.   halt(1);
  66.  end;
  67. writeln('Decoding ',infilename,', creating ',outfilename);
  68. while not eof(infile) do
  69.  begin
  70.   readln(infile,line);
  71. (*i:=pos(' ',line); *) (* uncomment this 2 lines, if you have problems with *)
  72. (*if i>0 then delete(line,i,length(line)); *) (* trailing blanks *)
  73.   len:=length(line);
  74.   index:=1;
  75.   while index<len do
  76.    begin
  77.     a:=fixchr(line(.index.));
  78.     index:=succ(index);
  79.     b:=fixchr(line(.index.));
  80.     index:=succ(index);
  81.     if a=nullchr then for i:=1 to b do write(outfile,#0)
  82.      else
  83.      begin
  84.       c:=fixchr(line(.index.));
  85.       index:=succ(index);
  86.       d:=fixchr(line(.index.));
  87.       index:=succ(index);
  88.       write(outfile,chr(a shl 2 or b shr 4));
  89.       write(outfile,chr(b shl 4 or c shr 2));
  90.       write(outfile,chr(c shl 6 or d));
  91.      end;
  92.   end;
  93.  end;
  94. (* write(outfile,#26); *) (* there is no need to append a ctrl-z *)
  95. close(infile);
  96. close(outfile);
  97. end.
  98.