home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / clipper / nannws35.arc / MEMOPACK.PRG < prev    next >
Encoding:
Text File  |  1989-03-01  |  9.3 KB  |  359 lines
  1. MemoPack.prg
  2.  
  3. * Program: MemoPack.prg
  4. * Editor:  Clayton Neff
  5. * Version: Clipper Summer '87
  6. * Note(s): Demonstrates DbtCrnch().
  7. *
  8.  
  9. CLEAR
  10. dbt_count = ADIR("*.DBT")
  11. DECLARE dbt_array[dbt_count], dbt_size[dbt_count]
  12.  
  13. * Read in all available .DBT files.
  14. ADIR("*.DBT", dbt_array, dbt_size)      
  15.  
  16. @ 2, 24 SAY "DbtCrnch() Demonstration Program"
  17. @ 4, 27 SAY "Written by : Clayton Neff"
  18. @ 7, 33 TO 8 + MIN(dbt_count, 10), 47 DOUBLE
  19. @ 19, 25 SAY "Select .DBT file to crunch."
  20.  
  21. * Use ACHOICE() to select the .DBT file to work on.
  22. dbt_choice = 0
  23. dbt_choice = ACHOICE(8, 34, 7 + MIN(dbt_count, 10), 46, dbt_array)
  24. IF(dbt_choice == 0)
  25.    QUIT
  26. ENDIF
  27. file_name = dbt_array[dbt_choice]
  28. start_size = dbt_size[dbt_choice]
  29.  
  30. * Strip ".DBT" from file_name and make copies.
  31. file_name = LEFT(file_name, AT('.', file_name) - 1)
  32. COPY FILE &file_name..DBF TO testtemp.fdb>null
  33. COPY FILE &file_name..DBT TO testtemp.tdb>null
  34. @ 7, 0 CLEAR TO 24, 79
  35. @ 7, 5 SAY "Starting .DBT file size - " + LTRIM(STR(start_size))
  36. @ 9, 5 SAY "Packing using COPY TO..."
  37.  
  38. * Pack with COPY TO.
  39. copy_time1 = SECONDS()
  40. USE &file_name.
  41. COPY TO TEMP
  42. ERASE &file_name..DBF
  43. ERASE &file_name..DBT
  44. RENAME TEMP.DBF TO &file_name..DBF
  45. RENAME TEMP.DBT TO &file_name..DBT
  46. copy_time2 = SECONDS()
  47. ADIR("*.dbt", dbt_array, dbt_size)      
  48. dbt_choice = ASCAN(dbt_array,file_name + ".DBT")
  49. copy_size = dbt_size[dbt_choice]
  50. @ 10, 5 SAY STR(start_size - copy_size) + " bytes saved in ";
  51.    + LTRIM(STR(copy_time2 - copy_time1)) + " seconds."
  52. COPY FILE testtemp.fdb TO &file_name..DBF>null
  53. COPY FILE testtemp.tdb TO &file_name..DBT>null
  54. @ 12, 5 SAY "Crunching with DbtCrnch()..."
  55.  
  56. * Crunch with DbtCrnch().
  57. crn_time1 = SECONDS()
  58. err_num = DbtCrnch(file_name)
  59. crn_time2 = SECONDS()
  60. ADIR("*.dbt", dbt_array, dbt_size)      
  61. dbt_choice = ASCAN(dbt_array,file_name + ".DBT")
  62. crn_size = dbt_size[dbt_choice]
  63. @ 13, 5 SAY STR(start_size - crn_size) + " bytes saved in ";
  64.    + LTRIM(STR(crn_time2 - crn_time1)) + " seconds."
  65. @ 14, 5 SAY "The error code returned was :" + STR(err_num,2,0)
  66. DO CASE
  67. CASE (err_num == 0)
  68.    @ 15, 15 SAY "No error!"
  69. CASE (err_num == 1)
  70.    @ 15, 15 SAY "Could not USE EXCLUSIVE."
  71. CASE (err_num == 2)
  72.    @ 15, 15 SAY "No memo fields found."
  73. CASE (err_num == 3)
  74.    @ 15, 15 SAY "Not enough disk space for copies."
  75. CASE (err_num == 4)
  76.    @ 15, 15 SAY "Error reading file."
  77. CASE (err_num == 5)
  78.    @ 15, 15 SAY "Error writing file."
  79. ENDCASE
  80.  
  81. * Display comparison results.
  82. @ 17, 5 SAY "DbtCrnch() .DBT is ";
  83.    + STR((crn_size/copy_size)*100,6,2) + "% of COPY TO in ";
  84.    + STR(((crn_time2-crn_time1)/(copy_time2-copy_time1))*100,6,2);
  85.    + "% of the time."
  86.  
  87. ERASE testtemp.fdb
  88. ERASE testtemp.tdb
  89.  
  90. @ 20, 0
  91. QUIT
  92.  
  93.  
  94.  
  95. * Function: DbtCrnch()
  96. * Note(s):  Packs DBT files.
  97. *           Returns the following error codes:
  98. *
  99. *           1 - Could not USE EXCULSIVE.
  100. *           2 - No memo fields found.
  101. *           3 - Not enough diskspace for copies.
  102. *           4 - Error reading file
  103. *           5 - Error writing file
  104. *
  105. FUNCTION DbtCrnch
  106. PARAMETERS file_name
  107. dbf_buff = SPACE(10)       && Buffer to hold pointers in DBF file.
  108. dbt_buff = SPACE(512)      && Buffer to hold data in DBT file.
  109.  
  110. * Remove extension from file name, if passed.
  111. IF(AT('.', file_name) != 0)
  112.    file_name = LEFT(file_name,;
  113.    AT('.', file_name) - 1)
  114. ENDIF
  115. dbf_name = file_name + ".DBF"
  116. dbt_name = file_name + ".DBT"
  117.  
  118. * Return error code 1 if cannot open file
  119. * exclusively.  This code is for networked
  120. * environments.  Comment this out for single
  121. * user situations, and uncomment the USE
  122. * statement below. NET_USE is outlined in
  123. * Nantucket News, Volume 1 Number 4.
  124. *
  125. *IF(! NET_USE(file_name, .T., 5))
  126. *   RETURN(1)
  127. *ENDIF
  128. *
  129. * This code is for single user environments.
  130. * Comment this out for networked situations,
  131. * and uncomment the NET_USE statements above.
  132.  
  133. USE (file_name)
  134.  
  135. fcnt = FCOUNT()
  136. rcnt = RECCOUNT()
  137. rsize = RECSIZE()
  138. hsize = HEADER()
  139. PRIVATE ftype[fcnt], fsize[fcnt], temp[fcnt]
  140. fname = ""
  141.  
  142. * Load file types and sizes into arrays.
  143. AFIELDS(fname, ftype, fsize)
  144. USE
  145.  
  146. total = 1
  147. num_mems = 0
  148.  
  149. * Find memo fields and thier offset in the
  150. * record.
  151. FOR i = 1 TO fcnt
  152.    IF ftype[i] = 'M'
  153.       num_mems = num_mems + 1
  154.       temp[num_mems] = total
  155.    ENDIF
  156.    total = total + fsize[i]
  157. NEXT i
  158.  
  159. * Return error code 2 if no memo fields found.
  160. IF(num_mems == 0)
  161.    RETURN(2)
  162. ENDIF
  163. PRIVATE mem_offset[num_mems]
  164. ACOPY(temp, mem_offset, 1, num_mems, 1)
  165. RELEASE temp
  166.  
  167. odbt_hndl = FOPEN(dbt_name, 18)
  168. IF(FERROR() != 0)
  169.    RETURN(1)
  170. ENDIF
  171. pntr = FSEEK(odbt_hndl, 0, 2) && Get current
  172.                              ** DBT file size.
  173. need_spc = (2 * pntr) + (hsize + (rsize+rcnt))
  174. FCLOSE(odbt_hndl)
  175.  
  176. * Return error code 3 if not enough room
  177. * on disk.
  178. IF(DISKSPACE() <= need_spc)
  179.    RETURN(3)
  180. ENDIF
  181.  
  182. * Make copies of the files to be packed.
  183. COPY FILE &dbf_name. TO temp.dbf>null
  184. COPY FILE &dbt_name. TO temp.dbt>null
  185.  
  186. * Open the copies and a new DBT file.
  187. odbt_hndl = FOPEN("temp.dbt", 18)
  188. IF(FERROR() != 0)
  189.    ERASE temp.dbt
  190.    ERASE temp.dbf
  191.    RETURN(1)
  192. ENDIF
  193. dbf_hndl = FOPEN("temp.dbf", 18)
  194. IF(FERROR() != 0)
  195.    FCLOSE(odbt_hndl)
  196.    ERASE temp.dbt
  197.    ERASE temp.dbf
  198.    RETURN(1)
  199. ENDIF
  200. ndbt_hndl = FCREATE("newdbt.dbt", 0)
  201. IF(FERROR() != 0)
  202.    FCLOSE(odbt_hndl)
  203.    FCLOSE(dbf_hndl)
  204.    ERASE temp.dbt
  205.    ERASE temp.dbf
  206.    RETURN(1)
  207. ENDIF
  208.  
  209. * Move to the beginning of both DBT files.
  210. * Read the first 512 byte block.
  211. FSEEK(odbt_hndl, 0, 0)
  212. FSEEK(ndbt_hndl, 0, 0)
  213. IF(FREAD(odbt_hndl, @dbt_buff, 512) != 512)
  214.    FCLOSE(ndbt_hndl)
  215.    FCLOSE(odbt_hndl)
  216.    FCLOSE(dbf_hndl)
  217.    ERASE temp.dbt
  218.    ERASE temp.dbf
  219.    ERASE newdbt.dbt
  220.    RETURN(4)
  221. ENDIF
  222.  
  223. * Calculate the next available block in
  224. * current DBT file.
  225. file_mems = ASC(LEFT(dbt_buff, 1))
  226. file_mems = file_mems + ;
  227.    (256 * ASC(SUBSTR(dbt_buff, 2, 1)))
  228. file_mems = file_mems + ;
  229.    (65536 * ASC(SUBSTR(dbt_buff, 3, 1)))
  230. file_mems = file_mems + ;
  231.    (16777216 * ASC(SUBSTR(dbt_buff, 4, 1)))
  232.  
  233. * Write the first 512 byte block to the new
  234. * DBT file.
  235. IF(FWRITE(ndbt_hndl, dbt_buff, 512) != 512)
  236.    FCLOSE(ndbt_hndl)
  237.    FCLOSE(odbt_hndl)
  238.    FCLOSE(dbf_hndl)
  239.    ERASE temp.dbt
  240.    ERASE temp.dbf
  241.    ERASE newdbt.dbt
  242.    RETURN(5)
  243. ENDIF
  244.  
  245. * Use BEGIN SEQUENCE to reduce exiting code in
  246. * copying loop.
  247. BEGIN SEQUENCE
  248.    sndbk = 0
  249.    buff_cntr = 1
  250.    FOR i = 1 TO rcnt
  251.       FOR j = 1 TO num_mems
  252.  
  253.          * Set pointer to memo field offset.
  254.          pntr = hsize + (rsize * (i - 1)) + ;
  255.             mem_offset[j]
  256.          FSEEK(dbf_hndl, pntr, 0)
  257.  
  258.          * Read 10 character pointer into DBT
  259.          * file.
  260.          IF(FREAD(dbf_hndl, @dbf_buff, 10);
  261.             != 10)
  262.             sndbk = 4
  263.             BREAK
  264.          ENDIF
  265.          * Loop if no memo stored.
  266.          IF(VAL(dbf_buff) == 0)
  267.             LOOP
  268.          ELSE
  269.             pntr = VAL(dbf_buff) * 512
  270.          ENDIF
  271.          FSEEK(odbt_hndl, pntr, 0)
  272.  
  273.          blcks = 1
  274.          DO WHILE .T.   && Loop while ! EOMemo
  275.  
  276.             * Read 512 characters at old memo
  277.             * location.
  278.             IF(FREAD(odbt_hndl,@dbt_buff,512);
  279.                != 512)
  280.                IF(FSEEK(odbt_hndl,0,1) * 512);
  281.                   < (file_mems - 1)
  282.                   sndbk = 4
  283.                   BREAK
  284.                ELSE
  285.                   dbt_buff = ;
  286.                      STUFF(SPACE(512), 1, ;
  287.                       LEN(dbt_buff), dbt_buff)
  288.                ENDIF
  289.             ENDIF
  290.  
  291.             * Write 512 characters at new memo
  292.             * location.
  293.             IF(FWRITE(ndbt_hndl,dbt_buff,512);
  294.                != 512)
  295.                sndbk = 5
  296.                BREAK
  297.             ENDIF
  298.             IF(AT(CHR(26), dbt_buff) == 0)
  299.                blcks = blcks + 1
  300.             ELSE
  301.                EXIT
  302.             ENDIF
  303.          ENDDO
  304.  
  305.          * Write new 10 character pointer into
  306.          * DBT file.
  307.          FSEEK(dbf_hndl, -10, 1)
  308.          dbf_buff = STR(buff_cntr, 10, 0)
  309.          IF(FWRITE(dbf_hndl, dbf_buff, 10);
  310.             != 10)
  311.             sndbk = 5
  312.             BREAK
  313.          ENDIF
  314.          buff_cntr = buff_cntr + blcks
  315.       NEXT j
  316.    NEXT i
  317. END
  318.  
  319. FCLOSE(dbf_hndl)
  320. FCLOSE(odbt_hndl)
  321.  
  322. * Calculate string for new next memo block.
  323. ncnt4 = INT(buff_cntr / 16777216)
  324. buff_cntr = buff_cntr - (ncnt4 * 16777216)
  325. ncnt3 = INT(buff_cntr / 65536)
  326. buff_cntr = buff_cntr - (ncnt3 * 65536)
  327. ncnt2 = INT(buff_cntr / 256)
  328. ncnt1 = buff_cntr - (ncnt2 * 256)
  329. dbt_buff = CHR(ncnt1) + CHR(ncnt2) + ;
  330.    CHR(ncnt3) + CHR(ncnt4)
  331.  
  332. * Move to beginning of new DBT and write next
  333. * block string.
  334. FSEEK(ndbt_hndl, 0, 0)
  335. IF(FWRITE(ndbt_hndl, dbt_buff, 4) != 4)
  336.    sndbk = 5
  337. ENDIF
  338. FCLOSE(ndbt_hndl)
  339. IF(sndbk == 0)       && Got through with no
  340.                      ** errors.
  341.    ERASE &dbt_name.  && Delete old DBT file.
  342.    ERASE &dbf_name.  && Delete old DBF file.
  343.    ERASE temp.dbt    && Delete old DBT file
  344.                      ** copy.
  345.    * Rename new DBT file.
  346.    RENAME newdbt.dbt TO &dbt_name.
  347.    * Rename new DBF file.
  348.    RENAME temp.dbf TO &dbf_name.
  349.  
  350. ELSE
  351.    ERASE temp.dbt    && Delete working copy
  352.                      ** of DBT file.
  353.    ERASE temp.dbf    && Delete working copy
  354.                      ** of DBF file.
  355.    ERASE newdbt.dbt  && Delete new copy of DBT
  356.                      ** file.
  357. ENDIF
  358. RETURN(sndbk)
  359.