home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / tug__002 / dearcio.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-08  |  6.8 KB  |  317 lines
  1. {TUG PDS CERT 1.01 (Pascal)
  2.  
  3. ==========================================================================
  4.  
  5.                   TUG PUBLIC DOMAIN SOFTWARE CERTIFICATION
  6.  
  7. The Turbo User Group (TUG) is recognized by Borland International as the
  8. official support organization for Turbo languages.  This file has been
  9. compiled and verified by the TUG library staff.  We are reasonably certain
  10. that the information contained in this file is public domain material, but
  11. it is also subject to any restrictions applied by its author.
  12.  
  13. This diskette contains PROGRAMS and/or DATA determined to be in the PUBLIC
  14. DOMAIN, provided as a service of TUG for the use of its members.  The
  15. Turbo User Group will not be liable for any damages, including any lost
  16. profits, lost savings or other incidental or consequential damages arising
  17. out of the use of or inability to use the contents, even if TUG has been
  18. advised of the possibility of such damages, or for any claim by any
  19. other party.
  20.  
  21. To the best of our knowledge, the routines in this file compile and function
  22. properly in accordance with the information described below.
  23.  
  24. If you discover an error in this file, we would appreciate it if you would
  25. report it to us.  To report bugs, or to request information on membership
  26. in TUG, please contact us at:
  27.  
  28.              Turbo User Group
  29.              PO Box 1510
  30.              Poulsbo, Washington USA  98370
  31.  
  32. --------------------------------------------------------------------------
  33.                        F i l e    I n f o r m a t i o n
  34.  
  35. * DESCRIPTION
  36. Turbo Pascal V4.0 DEARC input/output routines.
  37.  
  38. * ASSOCIATED FILES
  39. DEARC.PAS
  40. DEARCABT.PAS
  41. DEARCGLB.PAS
  42. DEARCIO.PAS
  43. DEARCLZW.PAS
  44. DEARCUNP.PAS
  45. DEARCUSQ.PAS
  46. DEARC.TXT
  47.  
  48. * CHECKED BY
  49. DRM 08/08/88
  50.  
  51. * KEYWORDS
  52. TURBO PASCAL V4.0
  53.  
  54. ==========================================================================
  55. }
  56. (**
  57.  *
  58.  *  Module:       dearcio.pas
  59.  *  Description:  DEARC input/output routines
  60.  *
  61.  *  Revision History:
  62.  *     7-26-88 : unitized for turbo 4.0
  63.  *
  64. **)
  65.  
  66. unit dearcio;
  67.  
  68. interface
  69. uses
  70.   dos,
  71.   dearcglb,
  72.   dearcabt;
  73.  
  74.   procedure open_arc;
  75.   procedure open_ext;
  76.   procedure close_arc;
  77.   procedure close_ext(var hdr : heads);
  78.   procedure fseek(offset : longint; base : integer);
  79.   procedure put_ext(c : byte);
  80.   function get_arc : byte;
  81.   procedure fread(var buf; reclen : integer);
  82.  
  83. implementation
  84.  
  85.  
  86. (**
  87.  *
  88.  *  Name:         procedure Read_Block
  89.  *  Description:  read a block from the archive file
  90.  *  Parameters:   none
  91.  *
  92. **)
  93. procedure Read_Block;
  94. var
  95.   res : word;
  96. begin
  97.   if EOF(arcfile) then
  98.     endfile := TRUE
  99.   else
  100.     BlockRead(arcfile, arcbuf, BLOCKSIZE, res);
  101.  
  102.   arcptr := 1
  103. end; (* proc read_block *)
  104.  
  105.  
  106. (**
  107.  *
  108.  *  Name:         procedure Write_Block
  109.  *  Description:  write a block to the extracted file
  110.  *  Parameters:   none
  111.  *
  112. **)
  113. procedure Write_Block;
  114. begin
  115.   BlockWrite(extfile, extbuf, extptr);
  116.   extptr := 1
  117. end; (* proc write_block *)
  118.  
  119.  
  120. (**
  121.  *
  122.  *  Name:         function get_arc : byte
  123.  *  Description:  read 1 character from the archive file
  124.  *  Parameters:   none
  125.  *  Returns:      character read
  126.  *
  127. **)
  128. function get_arc : byte;
  129. begin
  130.   if endfile then
  131.     get_arc := 0
  132.   else
  133.     begin
  134.       get_arc := arcbuf[arcptr];
  135.       if arcptr = BLOCKSIZE then
  136.         Read_Block
  137.       else
  138.         arcptr := arcptr + 1
  139.     end
  140. end; (* func get_arc *)
  141.  
  142.  
  143. (**
  144.  *
  145.  *  Name:         procedure put_ext
  146.  *  Description:  write 1 character to the extracted file
  147.  *  Parameters:   value -
  148.  *                  c : byte - character to write
  149.  *
  150. **)
  151. procedure put_ext(c : byte);
  152. begin
  153.   extbuf[extptr] := c;
  154.   if extptr = BLOCKSIZE then
  155.     Write_Block
  156.   else
  157.     extptr := extptr + 1
  158. end; (* proc put_ext *)
  159.  
  160.  
  161. (**
  162.  *
  163.  *  Name:         procedure open_arc
  164.  *  Description:  open the archive file for input processing
  165.  *  Parameters:   none
  166.  *
  167. **)
  168. procedure open_arc;
  169. begin
  170.   {$I-}
  171.     assign(arcfile, arcname);
  172.   {$I+}
  173.   if (ioresult <> 0) then
  174.     abort('Cannot open archive file.');
  175.  
  176.   {$I-}
  177.     reset(arcfile, 1);
  178.   {$I+}
  179.   if (ioresult <> 0) then
  180.     abort('Cannot open archive file.');
  181.  
  182.   endfile := FALSE;
  183.   Read_Block
  184. end; (* proc open_arc *)
  185.  
  186.  
  187. (**
  188.  *
  189.  *  Name:         procedure open_ext
  190.  *  Description:  open the extracted file for writing
  191.  *  Parameters:   none
  192.  *
  193. **)
  194. procedure open_ext;
  195. begin
  196.   {$I-}
  197.     assign(extfile, extname);
  198.   {$I+}
  199.   if (ioresult <> 0) then
  200.     abort('Cannot open extract file.');
  201.  
  202.   {$I-}
  203.     rewrite(extfile, 1);
  204.   {$I+}
  205.   if (ioresult <> 0) then
  206.     abort('Cannot open extract file.');
  207.  
  208.   extptr := 1;
  209. end; (* proc open_ext *)
  210.  
  211.  
  212. (**
  213.  *
  214.  *  Name:         procedure close_arc
  215.  *  Description:  close the archive file
  216.  *  Parameters:   none
  217.  *
  218. **)
  219. procedure close_arc;
  220. begin
  221.   close(arcfile)
  222. end; (* proc close_arc *)
  223.  
  224.  
  225. (**
  226.  *
  227.  *  Name:         procedure close_ext
  228.  *  Description:  close the extracted file
  229.  *  Parameters:   none
  230.  *
  231. **)
  232. procedure close_ext(var hdr : heads);
  233. var
  234.   dt     : longint;
  235.   regs   : registers;
  236.   handle : word;
  237. begin
  238.   extptr := extptr - 1;
  239.  
  240.   if (extptr <> 0) then
  241.     Write_Block;
  242.  
  243.   close(extfile);
  244.  
  245.  
  246.   (*
  247.    *  pbr  - 7-26-88 : added date stamping
  248.    *)
  249.   regs.ax := $3D00;                   (* open file *)
  250.   regs.ds := seg(hdr);
  251.   regs.dx := ofs(hdr.name);
  252.   MsDos(regs);
  253.  
  254.   handle := regs.ax;
  255.  
  256.   regs.ax := $5701;                   (* set date/time *)
  257.   regs.bx := handle;
  258.   regs.cx := hdr.time;
  259.   regs.dx := hdr.date;
  260.   MsDos(regs);
  261.  
  262.   regs.ah := $3E;                     (* close file *)
  263.   regs.bx := handle;
  264.   MsDos(regs);
  265. end; (* proc close_ext *)
  266.  
  267.  
  268. (**
  269.  *
  270.  *  Name:         procedure fseek
  271.  *  Description:  re-position the current pointer in the archive file
  272.  *  Parameters:   value -
  273.  *                  offset : longint - offset to position to
  274.  *                  base   : integer - position from:
  275.  *                             0 : beginning of file
  276.  *                             1 : current position
  277.  *                             2 : end-of-file
  278.  *
  279. **)
  280. procedure fseek(offset : longint; base : integer);
  281. var
  282.   b           : longint;
  283. begin
  284.   case base of
  285.     0 : b := offset;
  286.     1 : b := offset + FilePos(arcfile) - BLOCKSIZE + arcptr - 1;
  287.     2 : b := offset + FileSize(arcfile);
  288.     else
  289.       abort('Invalid parameters to fseek')
  290.   end;
  291.  
  292.   seek(arcfile, b);
  293.   Read_Block;
  294. end; (* proc fseek *)
  295.  
  296.  
  297. (**
  298.  *
  299.  *  Name:         procedure fread
  300.  *  Description:  read a record from the archive file
  301.  *  Parameters:   var -
  302.  *                  buf - buffer for read-in data
  303.  *                value -
  304.  *                  reclen : integer - items to read
  305.  *
  306. **)
  307. procedure fread(var buf; reclen : integer);
  308. var i : integer;
  309.     b : array [1..MaxInt] of byte absolute buf;
  310. begin
  311.   for i := 1 to reclen do
  312.     b[i] := get_arc
  313. end; (* proc fread *)
  314.  
  315. end.
  316.  
  317.