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 / ARCFUNC.INC < prev    next >
Text File  |  1989-11-12  |  5KB  |  164 lines
  1. (* ARCFUNC.INC TR 121189 *)
  2.  
  3. (* Folgende Prozeduren/Funktionen nur fuer Lese-Dateien! *)
  4.  
  5. (* Datei auf Anfang ruecksetzen *)
  6.  
  7. procedure freset(var f:binfile);
  8. begin
  9.   with f do begin seek(id,0); actpos:=long_null; feof:=false; end;
  10.   end;
  11.  
  12. (* Binaerfile eroeffnen *)
  13.  
  14. function fopen_read(name:filenam; var f:binfile):boolean;
  15. var last : integer;
  16. begin
  17.   with f do begin
  18.     assign(id,name);
  19.     {$I-} reset(id); {$I+}
  20.     fopen_read:=false;
  21.     if ioresult=0 then if filesize(id)>0 then begin
  22.       fopen_read:=true;
  23.       last:=pred(filesize(id));
  24.       fsize.hi:=0; fsize.lo:=last; shift_long(fsize,7);
  25.       seek(id,last); blockread(id,buff,1); last:=127;
  26.       while (buff[last]=$1A) and (last>0) do last:=pred(last);
  27.       fsize.b0:=fsize.b0 + last; inc_long(fsize);
  28.       freset(f);
  29.       end;
  30.     end;
  31.   end;
  32.  
  33. (* Einzelnes Zeichen aus Binaerfile holen (BYTE). *)
  34. (* nach Lesen des letzten Zeichens ist FEOF=TRUE. *)
  35. (* weiteres Lesen ergibt nur noch 00.             *)
  36.  
  37. function fgetc(var f:binfile):byte;
  38. begin
  39.   inline($ED/$5B/F/$21/$09/$01/$19/$CB/$46/$21/$00/$00/$C0/$21/$04/$01/
  40.   $19/$7E/$B7/$20/$19/$21/GI/$22/$E6/$00/$21/$09/$01/$19/$01/$02/$00/
  41.   $3E/$21/$CD/$FD/$1A/$CD/$1B/$20/$ED/$5B/F/$21/$04/$01/$19/$E5/$6E/
  42.   $26/$00/$19/$6E/$26/$00/$E3/$34/$20/$06/$23/$34/$20/$02/$23/$34/
  43.   $21/$04/$01/$19/$44/$4D/$21/$00/$01/$19/$0A/$96/$03/$23/$0A/$9E/
  44.   $03/$23/$0A/$9E/$3F/$3E/$00/$17/$21/$08/$01/$19/$77/$E1/$C9);
  45.   end;
  46.  
  47. (* Block in Datei uebergehen *)
  48.  
  49. procedure fskip(var f:binfile; offset:longword);
  50. begin
  51.   with f do begin
  52.     add_long(actpos,offset);
  53.     seek(id,actpos.mid shl 1);
  54.     if actpos.b0>0 then blockread(id,buff,2,gi);
  55.     inline($ED/$5B/F/$21/$04/$01/$19/$44/$4D/$21/$00/$01/$19/$0A/$96/
  56.     $03/$23/$0A/$9E/$03/$23/$0A/$9E/$3F/$3E/$00/$17/$21/$08/$01/$19/$77);
  57.     end;
  58.   end;
  59.  
  60. (* Folgende Prozeduren/Funktionen nur fuer Schreib-Dateien! *)
  61.  
  62. (* Binaerfile eroeffnen *)
  63.  
  64. procedure fopen_write(name:filenam; var f:binfile);
  65. begin
  66.   with f do begin
  67.     assign(id,name); rewrite(id); actpos:=long_null;
  68.     end;
  69.   end;
  70.  
  71. (* Einzelnes Zeichen in Binaerdatei schreiben. *)
  72.  
  73. procedure fputc(var f:binfile; c:byte);
  74. begin
  75.   inline($ED/$5B/F/$21/$04/$01/$19/$E5/$6E/$26/$00/$19/$3A/C/$77/$E1/
  76.   $34/$C0/$23/$34/$20/$02/$23/$34);
  77.   blockwrite(f.id,f.buff,2);
  78.   end;
  79.  
  80. (* Binaerfile schliessen. Evtl. noch Puffer speichern *)
  81.  
  82. procedure fclose(var f:binfile);
  83. var sav : byte;
  84. begin
  85.   with f do begin
  86.     sav:=actpos.b0;
  87.     if sav>0 then begin
  88.       fillchar(buff[sav],256-sav,$1A);
  89.       if sav>128 then sav:=2 else sav:=1;
  90.       blockwrite(id,buff,sav);
  91.       end;
  92.     close(id);
  93.     end;
  94.   end;
  95.  
  96. (* CRC-Bearbeitung *)
  97.  
  98. procedure addcrc(var crc:integer; cod:byte);
  99. const crctab : array[0..255] of integer =
  100.    ($0000,$C0C1,$C181,$0140,$C301,$03C0,$0280,$C241,$C601,$06C0,$0780,$C741,
  101.     $0500,$C5C1,$C481,$0440,$CC01,$0CC0,$0D80,$CD41,$0F00,$CFC1,$CE81,$0E40,
  102.     $0A00,$CAC1,$CB81,$0B40,$C901,$09C0,$0880,$C841,$D801,$18C0,$1980,$D941,
  103.     $1B00,$DBC1,$DA81,$1A40,$1E00,$DEC1,$DF81,$1F40,$DD01,$1DC0,$1C80,$DC41,
  104.     $1400,$D4C1,$D581,$1540,$D701,$17C0,$1680,$D641,$D201,$12C0,$1380,$D341,
  105.     $1100,$D1C1,$D081,$1040,$F001,$30C0,$3180,$F141,$3300,$F3C1,$F281,$3240,
  106.     $3600,$F6C1,$F781,$3740,$F501,$35C0,$3480,$F441,$3C00,$FCC1,$FD81,$3D40,
  107.     $FF01,$3FC0,$3E80,$FE41,$FA01,$3AC0,$3B80,$FB41,$3900,$F9C1,$F881,$3840,
  108.     $2800,$E8C1,$E981,$2940,$EB01,$2BC0,$2A80,$EA41,$EE01,$2EC0,$2F80,$EF41,
  109.     $2D00,$EDC1,$EC81,$2C40,$E401,$24C0,$2580,$E541,$2700,$E7C1,$E681,$2640,
  110.     $2200,$E2C1,$E381,$2340,$E101,$21C0,$2080,$E041,$A001,$60C0,$6180,$A141,
  111.     $6300,$A3C1,$A281,$6240,$6600,$A6C1,$A781,$6740,$A501,$65C0,$6480,$A441,
  112.     $6C00,$ACC1,$AD81,$6D40,$AF01,$6FC0,$6E80,$AE41,$AA01,$6AC0,$6B80,$AB41,
  113.     $6900,$A9C1,$A881,$6840,$7800,$B8C1,$B981,$7940,$BB01,$7BC0,$7A80,$BA41,
  114.     $BE01,$7EC0,$7F80,$BF41,$7D00,$BDC1,$BC81,$7C40,$B401,$74C0,$7580,$B541,
  115.     $7700,$B7C1,$B681,$7640,$7200,$B2C1,$B381,$7340,$B101,$71C0,$7080,$B041,
  116.     $5000,$90C1,$9181,$5140,$9301,$53C0,$5280,$9241,$9601,$56C0,$5780,$9741,
  117.     $5500,$95C1,$9481,$5440,$9C01,$5CC0,$5D80,$9D41,$5F00,$9FC1,$9E81,$5E40,
  118.     $5A00,$9AC1,$9B81,$5B40,$9901,$59C0,$5880,$9841,$8801,$48C0,$4980,$8941,
  119.     $4B00,$8BC1,$8A81,$4A40,$4E00,$8EC1,$8F81,$4F40,$8D01,$4DC0,$4C80,$8C41,
  120.     $4400,$84C1,$8581,$4540,$8701,$47C0,$4680,$8641,$8201,$42C0,$4380,$8341,
  121.     $4100,$81C1,$8081,$4040);
  122. begin
  123.   inline($2A/CRC/$5E/$23/$56/$3A/COD/$AB/$4F/$06/$00/$DD/$21/CRCTAB/
  124.   $DD/$09/$DD/$09/$DD/$7E/$01/$77/$2B/$DD/$7E/$00/$AA/$77);
  125.   end;
  126.  
  127. (* ARC-File(s) oeffnen bzw. schliessen *)
  128.  
  129. var oldexist,newflag : boolean;
  130.  
  131. function openarc(flag:boolean):boolean;
  132. begin
  133.   newflag:=flag;
  134.   oldexist:=fopen_read(arcpath+arcname,oldarc);
  135.   if newflag then begin
  136.     writeln('Creating new archive ...');
  137.     fopen_write(arcpath+newname,newarc);
  138.     end;
  139.   openarc:=oldexist;
  140.   end;
  141.  
  142. procedure closearc;
  143.  
  144.   procedure filerename(var f:binfile; var nam:filenam);
  145.   var h : file;
  146.   begin
  147.     assign(h,arcpath+nam);
  148.     {$I-} reset(h); {$I+}
  149.     if ioresult=0 then begin close(h); erase(h); end;
  150.     rename(f.id,nam);
  151.     end;
  152.  
  153. begin
  154.   if newflag then begin
  155.     fclose(newarc);
  156.     if oldexist then begin
  157.       close(oldarc.id);
  158.       if keepbak then filerename(oldarc,bakname) else erase(oldarc.id);
  159.       end;
  160.     filerename(newarc,arcname);
  161.     end;
  162.   end;
  163.  
  164.