home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / A / ARC20.ARC / ARCIO.INC < prev    next >
Text File  |  1989-11-10  |  5KB  |  163 lines
  1. (* ARCIO.INC  TR 311089 *)
  2.  
  3. (* Header aus ARC-File lesen und schreiben *)
  4.  
  5. const first_io : boolean = true;
  6.  
  7. function readhdr(var hdr:headtype; var f:binfile):boolean;
  8. var i : byte;
  9. begin
  10.   readhdr:=false; fillchar(hdr,sizeof(hdr),0);
  11.   if f.feof then exit;
  12.   if fgetc(f)=$1A then hdr.vers:=fgetc(f) else begin
  13.     if warn then writeln(^M^J'An entry in ',arcname,' has a bad header.');
  14.     i:=0; hdr.vers:=$FF;
  15.     repeat
  16.       i:=succ(i);
  17.       if fgetc(f)=$1A then begin hdr.vers:=fgetc(f); i:=succ(i); end;
  18.     until f.feof or (hdr.vers<=9);
  19.     if f.feof then if first_io then begin
  20.       writeln(arcname,' is not an archive.'); halt; end
  21.       else exit;
  22.     if warn then writeln(i,' Bytes skipped.');
  23.     end;
  24.   if hdr.vers=0 then exit;
  25.   if f.feof then begin
  26.     writeln('Invalid header in archive ',arcname); halt; end;
  27.   if hdr.vers=1 then begin
  28.     writeln('Sorry: old style not implemented.'); halt; end;
  29.   for i:=2 to 28 do hdr.arr[i]:=fgetc(f);
  30.   if hdr.vers>9 then begin
  31.     writeln('I dont know how to handle file ',pstring(hdr.name),' in archive ',
  32.             arcname,^M^J'I think you need a newer version of ARC.');
  33.     halt; end;
  34.   first_io:=false; readhdr:=true;
  35.   end;
  36.  
  37. procedure writehdr(var hdr:headtype; var f:binfile);
  38. var i : byte;
  39. begin
  40.   fputc(f,$1A);
  41.   fputc(f,hdr.vers);
  42.   if hdr.vers>0 then for i:=2 to 28 do fputc(f,hdr.arr[i]);
  43.   end;
  44.  
  45. (* Verschluesseln bzw. Entschluesseln von Dateien *)
  46.  
  47. var crypt_point : byte;
  48.  
  49. procedure init_crypt;
  50. begin
  51.   crypt_point:=1;
  52.   end;
  53.  
  54. function crypt(cod:byte):byte;
  55. begin
  56.   inline($3A/PASS/$B7/$2A/COD/$26/$00/$C8/$47/$7D/$ED/$5B/CRYPT_POINT/
  57.   $16/$00/$21/PASS/$19/$AE/$6F/$26/$00/$E5/$7B/$B8/$30/$06/$3C/$32/CRYPT_POINT/
  58.   $E1/$C9/$3E/$01/$32/CRYPT_POINT/$E1/$C9);
  59.   end;
  60.  
  61. (* Datenblock von einer Datei zur anderen kopieren, *)
  62. (* dabei u.U. Ver/Entschluesseln der Daten.         *)
  63. (* CRYPT_POINT wird dabei nicht initialisiert!      *)
  64.  
  65. procedure filecopy(var source,dest:binfile; size:longword; cryptflag:boolean);
  66. type buffer            = array[0..maxint] of byte;
  67. var  bufptr            : ^buffer;
  68.      bufsiz,pages,cp,i : integer;
  69. begin
  70.   bufsiz:=maxavail and $7F00;
  71.   getmem(bufptr,bufsiz);
  72.   if cryptflag then for i:=1 to size.b0 do fputc(dest,crypt(fgetc(source)))
  73.   else for i:=1 to size.b0 do fputc(dest,fgetc(source));
  74.   pages:=size.mid;
  75.   while pages>0 do begin
  76.     if pages>=hi(bufsiz) then cp:=bufsiz else cp:=pages shl 8;
  77.     for i:=0 to pred(cp) do bufptr^[i]:=fgetc(source);
  78.     if cryptflag then for i:=0 to pred(cp) do fputc(dest,crypt(bufptr^[i]))
  79.     else for i:=0 to pred(cp) do fputc(dest,bufptr^[i]);
  80.     pages:=pages-hi(cp);
  81.     end;
  82.   freemem(bufptr,bufsiz);
  83.   end;
  84.  
  85. (* Direktes BinaerFile-I/O mit CRC-Berechnung. *)
  86.  
  87. var crcval   : integer;
  88.  
  89. procedure putc_dir(var f:binfile; c:byte);
  90. begin
  91.   addcrc(crcval,c);
  92.   fputc(f,c);
  93.   end;
  94.  
  95. function getc_dir(var f:binfile):byte;
  96. var c : byte;
  97. begin
  98.   if f.feof then getc_dir:=0
  99.   else begin
  100.     c:=fgetc(f);
  101.     addcrc(crcval,c);
  102.     getc_dir:=c;
  103.     end;
  104.   end;
  105.  
  106. (* Zeichen aus Datei holen und Zaehler SIZ dekrementieren *)
  107.  
  108. var siz : longword;
  109.  
  110. function getc_decsiz(var f:binfile):byte;
  111. begin
  112.   getc_decsiz:=fgetc(f); dec_long(siz);
  113.   end;
  114.  
  115. (* NCR-Packing / Unpacking. GETC_NCR liest Zeichen aus Datei und  *)
  116. (* liefert komprimiertes (gepacktes) Ergebnisbyte.                *)
  117. (* Flag NCREND wird nach Uebergabe des letzten NCR-Bytes gesetzt. *)
  118. (* Zaehler NCRLEN wird bei jedem GETC_NCR-Aufruf inkrementiert.   *)
  119. (* PUTC_NCR expandiert uebergebenes Byte in Ausgabedatei.         *)
  120. (* GETC: Zeichenzaehler VALCOUNT wird erhoeht.                    *)
  121.  
  122. var ncrstate,ncrlast : byte;
  123.     ncrlen           : longword;
  124.     ncrend           : boolean;
  125.     valcount         : array[0..256] of longword;  (* SPEOF! *)
  126.  
  127. procedure init_ncr;
  128. begin
  129.   ncrstate:=0; ncrlen:=long_null;
  130.   fillchar(valcount,sizeof(valcount),0);
  131.   end;
  132.  
  133. function getc_ncr(var f:binfile):integer;
  134. const cc  : byte = 0;
  135.       rep : byte = 0;
  136. begin
  137.   inc_long(ncrlen);
  138.   inline($ED/$5B/F/$DD/$21/$08/$01/$DD/$19/$3A/NCRSTATE/$3D/$28/$4E/
  139.   $3D/$28/$1A/$3D/$28/$2D/$3E/$01/$32/NCRSTATE/$DD/$E5/$D5/$CD/GETC_DIR/
  140.   $DD/$E1/$7D/$32/NCRLAST/$FE/$90/$28/$22/$18/$0E/$3E/$01/$32/NCRSTATE/
  141.   $2A/CC/$26/$00/$7D/$32/NCRLAST/$DD/$7E/$00/$32/NCREND/$18/$0E/$3E/$02/
  142.   $32/NCRSTATE/$2A/REP/$26/$00/$AF/$32/NCREND/$E5/$29/$29/$11/VALCOUNT/
  143.   $19/$E5/$CD/INC_LONG/$E1/$C9/$3A/NCRLAST/$FE/$90/$20/$09/$AF/$32/NCRSTATE/
  144.   $21/$00/$00/$18/$CD/$06/$00/$04/$DD/$E5/$C5/$2A/F/$E5/$CD/GETC_DIR/
  145.   $C1/$DD/$E1/$3A/NCRLAST/$BD/$20/$0A/$78/$3C/$28/$06/$DD/$CB/$00/$46/
  146.   $28/$E2/$7D/$32/CC/$78/$32/REP/$3D/$28/$0D/$3D/$28/$10/$3E/$03/$32/NCRSTATE/
  147.   $21/$90/$00/$18/$A7/$7D/$32/NCRLAST/$18/$8F/$3E/$02/$32/NCRSTATE/
  148.   $2A/NCRLAST/$26/$00/$18/$95);
  149.   end;
  150.  
  151. procedure putc_ncr(var f:binfile; c:byte);
  152. var i : byte;
  153. begin
  154.   case ncrstate of
  155.     1 : begin
  156.           if c>0 then for i:=1 to pred(c) do putc_dir(f,ncrlast)
  157.             else putc_dir(f,$90);
  158.           ncrstate:=0;
  159.           end;
  160. {0} else if c=$90 then ncrstate:=1 else begin ncrlast:=c; putc_dir(f,ncrlast) end;
  161.     end;
  162.   end;
  163.