home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / packer / arc / arctool / dearcio.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-09-29  |  5.2 KB  |  280 lines
  1. {
  2.                        F i l e    I n f o r m a t i o n
  3.  
  4. * DESCRIPTION
  5. Turbo Pascal V4.0 DEARC input/output routines.
  6.  
  7. * ASSOCIATED FILES
  8. DEARC.PAS
  9. DEARCABT.PAS
  10. DEARCGLB.PAS
  11. DEARCIO.PAS
  12. DEARCLZW.PAS
  13. DEARCUNP.PAS
  14. DEARCUSQ.PAS
  15. DEARC.TXT
  16.  
  17. }
  18. (**
  19.  *
  20.  *  Module:       dearcio.pas
  21.  *  Description:  DEARC input/output routines
  22.  *
  23.  *  Revision History:
  24.  *     7-26-88 : unitized for turbo 4.0
  25.  *
  26. **)
  27.  
  28. unit dearcio;
  29.  
  30. interface
  31. uses
  32.   dos,
  33.   dearcglb,
  34.   dearcabt;
  35.  
  36.   procedure open_arc;
  37.   procedure open_ext;
  38.   procedure close_arc;
  39.   procedure close_ext(var hdr : heads);
  40.   procedure fseek(offset : longint; base : integer);
  41.   procedure put_ext(c : byte);
  42.   function get_arc : byte;
  43.   procedure fread(var buf; reclen : integer);
  44.  
  45. implementation
  46.  
  47.  
  48. (**
  49.  *
  50.  *  Name:         procedure Read_Block
  51.  *  Description:  read a block from the archive file
  52.  *  Parameters:   none
  53.  *
  54. **)
  55. procedure Read_Block;
  56. var
  57.   res : word;
  58. begin
  59.   if EOF(arcfile) then
  60.     endfile := TRUE
  61.   else
  62.     BlockRead(arcfile, arcbuf, BLOCKSIZE, res);
  63.  
  64.   arcptr := 1
  65. end; (* proc read_block *)
  66.  
  67.  
  68. (**
  69.  *
  70.  *  Name:         procedure Write_Block
  71.  *  Description:  write a block to the extracted file
  72.  *  Parameters:   none
  73.  *
  74. **)
  75. procedure Write_Block;
  76. begin
  77.   BlockWrite(extfile, extbuf, extptr);
  78.   extptr := 1
  79. end; (* proc write_block *)
  80.  
  81.  
  82. (**
  83.  *
  84.  *  Name:         function get_arc : byte
  85.  *  Description:  read 1 character from the archive file
  86.  *  Parameters:   none
  87.  *  Returns:      character read
  88.  *
  89. **)
  90. function get_arc : byte;
  91. begin
  92.   if endfile then
  93.     get_arc := 0
  94.   else
  95.     begin
  96.       get_arc := arcbuf[arcptr];
  97.       if arcptr = BLOCKSIZE then
  98.         Read_Block
  99.       else
  100.         arcptr := arcptr + 1
  101.     end
  102. end; (* func get_arc *)
  103.  
  104.  
  105. (**
  106.  *
  107.  *  Name:         procedure put_ext
  108.  *  Description:  write 1 character to the extracted file
  109.  *  Parameters:   value -
  110.  *                  c : byte - character to write
  111.  *
  112. **)
  113. procedure put_ext(c : byte);
  114. begin
  115.   extbuf[extptr] := c;
  116.   if extptr = BLOCKSIZE then
  117.     Write_Block
  118.   else
  119.     extptr := extptr + 1
  120. end; (* proc put_ext *)
  121.  
  122.  
  123. (**
  124.  *
  125.  *  Name:         procedure open_arc
  126.  *  Description:  open the archive file for input processing
  127.  *  Parameters:   none
  128.  *
  129. **)
  130. procedure open_arc;
  131. begin
  132.   {$I-}
  133.     assign(arcfile, arcname);
  134.   {$I+}
  135.   if (ioresult <> 0) then
  136.     abort('Cannot open archive file.');
  137.  
  138.   {$I-}
  139.     reset(arcfile, 1);
  140.   {$I+}
  141.   if (ioresult <> 0) then
  142.     abort('Cannot open archive file.');
  143.  
  144.   endfile := FALSE;
  145.   Read_Block
  146. end; (* proc open_arc *)
  147.  
  148.  
  149. (**
  150.  *
  151.  *  Name:         procedure open_ext
  152.  *  Description:  open the extracted file for writing
  153.  *  Parameters:   none
  154.  *
  155. **)
  156. procedure open_ext;
  157. begin
  158.   {$I-}
  159.     assign(extfile, extname);
  160.   {$I+}
  161.   if (ioresult <> 0) then
  162.     abort('Cannot open extract file.');
  163.  
  164.   {$I-}
  165.     rewrite(extfile, 1);
  166.   {$I+}
  167.   if (ioresult <> 0) then
  168.     abort('Cannot open extract file.');
  169.  
  170.   extptr := 1;
  171. end; (* proc open_ext *)
  172.  
  173.  
  174. (**
  175.  *
  176.  *  Name:         procedure close_arc
  177.  *  Description:  close the archive file
  178.  *  Parameters:   none
  179.  *
  180. **)
  181. procedure close_arc;
  182. begin
  183.   close(arcfile)
  184. end; (* proc close_arc *)
  185.  
  186.  
  187. (**
  188.  *
  189.  *  Name:         procedure close_ext
  190.  *  Description:  close the extracted file
  191.  *  Parameters:   none
  192.  *
  193. **)
  194. procedure close_ext(var hdr : heads);
  195. var
  196.   dt     : longint;
  197.   regs   : registers;
  198.   handle : word;
  199. begin
  200.   extptr := extptr - 1;
  201.  
  202.   if (extptr <> 0) then
  203.     Write_Block;
  204.  
  205.   close(extfile);
  206.  
  207.  
  208.   (*
  209.    *  pbr  - 7-26-88 : added date stamping
  210.    *)
  211.   regs.ax := $3D00;                   (* open file *)
  212.   regs.ds := seg(hdr);
  213.   regs.dx := ofs(hdr.name);
  214.   MsDos(regs);
  215.  
  216.   handle := regs.ax;
  217.  
  218.   regs.ax := $5701;                   (* set date/time *)
  219.   regs.bx := handle;
  220.   regs.cx := hdr.time;
  221.   regs.dx := hdr.date;
  222.   MsDos(regs);
  223.  
  224.   regs.ah := $3E;                     (* close file *)
  225.   regs.bx := handle;
  226.   MsDos(regs);
  227. end; (* proc close_ext *)
  228.  
  229.  
  230. (**
  231.  *
  232.  *  Name:         procedure fseek
  233.  *  Description:  re-position the current pointer in the archive file
  234.  *  Parameters:   value -
  235.  *                  offset : longint - offset to position to
  236.  *                  base   : integer - position from:
  237.  *                             0 : beginning of file
  238.  *                             1 : current position
  239.  *                             2 : end-of-file
  240.  *
  241. **)
  242. procedure fseek(offset : longint; base : integer);
  243. var
  244.   b           : longint;
  245. begin
  246.   case base of
  247.     0 : b := offset;
  248.     1 : b := offset + FilePos(arcfile) - BLOCKSIZE + arcptr - 1;
  249.     2 : b := offset + FileSize(arcfile);
  250.     else
  251.       abort('Invalid parameters to fseek')
  252.   end;
  253.  
  254.   seek(arcfile, b);
  255.   Read_Block;
  256. end; (* proc fseek *)
  257.  
  258.  
  259. (**
  260.  *
  261.  *  Name:         procedure fread
  262.  *  Description:  read a record from the archive file
  263.  *  Parameters:   var -
  264.  *                  buf - buffer for read-in data
  265.  *                value -
  266.  *                  reclen : integer - items to read
  267.  *
  268. **)
  269. procedure fread(var buf; reclen : integer);
  270. var i : integer;
  271.     b : array [1..MaxInt] of byte absolute buf;
  272. begin
  273.   for i := 1 to reclen do
  274.     b[i] := get_arc
  275. end; (* proc fread *)
  276.  
  277. end.
  278.  
  279. 
  280.