Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0305.ZIP
Filename : MEMOPACK.PRG

 
Output of file : MEMOPACK.PRG contained in archive : NN0305.ZIP
MemoPack.prg

* Program: MemoPack.prg
* Editor: Clayton Neff
* Version: Clipper Summer '87
* Note(s): Demonstrates DbtCrnch().
*

CLEAR
dbt_count = ADIR("*.DBT")
DECLARE dbt_array[dbt_count], dbt_size[dbt_count]

* Read in all available .DBT files.
ADIR("*.DBT", dbt_array, dbt_size)

@ 2, 24 SAY "DbtCrnch() Demonstration Program"
@ 4, 27 SAY "Written by : Clayton Neff"
@ 7, 33 TO 8 + MIN(dbt_count, 10), 47 DOUBLE
@ 19, 25 SAY "Select .DBT file to crunch."

* Use ACHOICE() to select the .DBT file to work on.
dbt_choice = 0
dbt_choice = ACHOICE(8, 34, 7 + MIN(dbt_count, 10), 46, dbt_array)
IF(dbt_choice == 0)
QUIT
ENDIF
file_name = dbt_array[dbt_choice]
start_size = dbt_size[dbt_choice]

* Strip ".DBT" from file_name and make copies.
file_name = LEFT(file_name, AT('.', file_name) - 1)
COPY FILE &file_name..DBF TO testtemp.fdb>null
COPY FILE &file_name..DBT TO testtemp.tdb>null
@ 7, 0 CLEAR TO 24, 79
@ 7, 5 SAY "Starting .DBT file size - " + LTRIM(STR(start_size))
@ 9, 5 SAY "Packing using COPY TO..."

* Pack with COPY TO.
copy_time1 = SECONDS()
USE &file_name.
COPY TO TEMP
ERASE &file_name..DBF
ERASE &file_name..DBT
RENAME TEMP.DBF TO &file_name..DBF
RENAME TEMP.DBT TO &file_name..DBT
copy_time2 = SECONDS()
ADIR("*.dbt", dbt_array, dbt_size)
dbt_choice = ASCAN(dbt_array,file_name + ".DBT")
copy_size = dbt_size[dbt_choice]
@ 10, 5 SAY STR(start_size - copy_size) + " bytes saved in ";
+ LTRIM(STR(copy_time2 - copy_time1)) + " seconds."
COPY FILE testtemp.fdb TO &file_name..DBF>null
COPY FILE testtemp.tdb TO &file_name..DBT>null
@ 12, 5 SAY "Crunching with DbtCrnch()..."

* Crunch with DbtCrnch().
crn_time1 = SECONDS()
err_num = DbtCrnch(file_name)
crn_time2 = SECONDS()
ADIR("*.dbt", dbt_array, dbt_size)
dbt_choice = ASCAN(dbt_array,file_name + ".DBT")
crn_size = dbt_size[dbt_choice]
@ 13, 5 SAY STR(start_size - crn_size) + " bytes saved in ";
+ LTRIM(STR(crn_time2 - crn_time1)) + " seconds."
@ 14, 5 SAY "The error code returned was :" + STR(err_num,2,0)
DO CASE
CASE (err_num == 0)
@ 15, 15 SAY "No error!"
CASE (err_num == 1)
@ 15, 15 SAY "Could not USE EXCLUSIVE."
CASE (err_num == 2)
@ 15, 15 SAY "No memo fields found."
CASE (err_num == 3)
@ 15, 15 SAY "Not enough disk space for copies."
CASE (err_num == 4)
@ 15, 15 SAY "Error reading file."
CASE (err_num == 5)
@ 15, 15 SAY "Error writing file."
ENDCASE

* Display comparison results.
@ 17, 5 SAY "DbtCrnch() .DBT is ";
+ STR((crn_size/copy_size)*100,6,2) + "% of COPY TO in ";
+ STR(((crn_time2-crn_time1)/(copy_time2-copy_time1))*100,6,2);
+ "% of the time."

ERASE testtemp.fdb
ERASE testtemp.tdb

@ 20, 0
QUIT



* Function: DbtCrnch()
* Note(s): Packs DBT files.
* Returns the following error codes:
*
* 1 - Could not USE EXCULSIVE.
* 2 - No memo fields found.
* 3 - Not enough diskspace for copies.
* 4 - Error reading file
* 5 - Error writing file
*
FUNCTION DbtCrnch
PARAMETERS file_name
dbf_buff = SPACE(10) && Buffer to hold pointers in DBF file.
dbt_buff = SPACE(512) && Buffer to hold data in DBT file.

* Remove extension from file name, if passed.
IF(AT('.', file_name) != 0)
file_name = LEFT(file_name,;
AT('.', file_name) - 1)
ENDIF
dbf_name = file_name + ".DBF"
dbt_name = file_name + ".DBT"

* Return error code 1 if cannot open file
* exclusively. This code is for networked
* environments. Comment this out for single
* user situations, and uncomment the USE
* statement below. NET_USE is outlined in
* Nantucket News, Volume 1 Number 4.
*
*IF(! NET_USE(file_name, .T., 5))
* RETURN(1)
*ENDIF
*
* This code is for single user environments.
* Comment this out for networked situations,
* and uncomment the NET_USE statements above.

USE (file_name)

fcnt = FCOUNT()
rcnt = RECCOUNT()
rsize = RECSIZE()
hsize = HEADER()
PRIVATE ftype[fcnt], fsize[fcnt], temp[fcnt]
fname = ""

* Load file types and sizes into arrays.
AFIELDS(fname, ftype, fsize)
USE

total = 1
num_mems = 0

* Find memo fields and thier offset in the
* record.
FOR i = 1 TO fcnt
IF ftype[i] = 'M'
num_mems = num_mems + 1
temp[num_mems] = total
ENDIF
total = total + fsize[i]
NEXT i

* Return error code 2 if no memo fields found.
IF(num_mems == 0)
RETURN(2)
ENDIF
PRIVATE mem_offset[num_mems]
ACOPY(temp, mem_offset, 1, num_mems, 1)
RELEASE temp

odbt_hndl = FOPEN(dbt_name, 18)
IF(FERROR() != 0)
RETURN(1)
ENDIF
pntr = FSEEK(odbt_hndl, 0, 2) && Get current
** DBT file size.
need_spc = (2 * pntr) + (hsize + (rsize+rcnt))
FCLOSE(odbt_hndl)

* Return error code 3 if not enough room
* on disk.
IF(DISKSPACE() <= need_spc)
RETURN(3)
ENDIF

* Make copies of the files to be packed.
COPY FILE &dbf_name. TO temp.dbf>null
COPY FILE &dbt_name. TO temp.dbt>null

* Open the copies and a new DBT file.
odbt_hndl = FOPEN("temp.dbt", 18)
IF(FERROR() != 0)
ERASE temp.dbt
ERASE temp.dbf
RETURN(1)
ENDIF
dbf_hndl = FOPEN("temp.dbf", 18)
IF(FERROR() != 0)
FCLOSE(odbt_hndl)
ERASE temp.dbt
ERASE temp.dbf
RETURN(1)
ENDIF
ndbt_hndl = FCREATE("newdbt.dbt", 0)
IF(FERROR() != 0)
FCLOSE(odbt_hndl)
FCLOSE(dbf_hndl)
ERASE temp.dbt
ERASE temp.dbf
RETURN(1)
ENDIF

* Move to the beginning of both DBT files.
* Read the first 512 byte block.
FSEEK(odbt_hndl, 0, 0)
FSEEK(ndbt_hndl, 0, 0)
IF(FREAD(odbt_hndl, @dbt_buff, 512) != 512)
FCLOSE(ndbt_hndl)
FCLOSE(odbt_hndl)
FCLOSE(dbf_hndl)
ERASE temp.dbt
ERASE temp.dbf
ERASE newdbt.dbt
RETURN(4)
ENDIF

* Calculate the next available block in
* current DBT file.
file_mems = ASC(LEFT(dbt_buff, 1))
file_mems = file_mems + ;
(256 * ASC(SUBSTR(dbt_buff, 2, 1)))
file_mems = file_mems + ;
(65536 * ASC(SUBSTR(dbt_buff, 3, 1)))
file_mems = file_mems + ;
(16777216 * ASC(SUBSTR(dbt_buff, 4, 1)))

* Write the first 512 byte block to the new
* DBT file.
IF(FWRITE(ndbt_hndl, dbt_buff, 512) != 512)
FCLOSE(ndbt_hndl)
FCLOSE(odbt_hndl)
FCLOSE(dbf_hndl)
ERASE temp.dbt
ERASE temp.dbf
ERASE newdbt.dbt
RETURN(5)
ENDIF

* Use BEGIN SEQUENCE to reduce exiting code in
* copying loop.
BEGIN SEQUENCE
sndbk = 0
buff_cntr = 1
FOR i = 1 TO rcnt
FOR j = 1 TO num_mems

* Set pointer to memo field offset.
pntr = hsize + (rsize * (i - 1)) + ;
mem_offset[j]
FSEEK(dbf_hndl, pntr, 0)

* Read 10 character pointer into DBT
* file.
IF(FREAD(dbf_hndl, @dbf_buff, 10);
!= 10)
sndbk = 4
BREAK
ENDIF
* Loop if no memo stored.
IF(VAL(dbf_buff) == 0)
LOOP
ELSE
pntr = VAL(dbf_buff) * 512
ENDIF
FSEEK(odbt_hndl, pntr, 0)

blcks = 1
DO WHILE .T. && Loop while ! EOMemo

* Read 512 characters at old memo
* location.
IF(FREAD(odbt_hndl,@dbt_buff,512);
!= 512)
IF(FSEEK(odbt_hndl,0,1) * 512);
< (file_mems - 1)
sndbk = 4
BREAK
ELSE
dbt_buff = ;
STUFF(SPACE(512), 1, ;
LEN(dbt_buff), dbt_buff)
ENDIF
ENDIF

* Write 512 characters at new memo
* location.
IF(FWRITE(ndbt_hndl,dbt_buff,512);
!= 512)
sndbk = 5
BREAK
ENDIF
IF(AT(CHR(26), dbt_buff) == 0)
blcks = blcks + 1
ELSE
EXIT
ENDIF
ENDDO

* Write new 10 character pointer into
* DBT file.
FSEEK(dbf_hndl, -10, 1)
dbf_buff = STR(buff_cntr, 10, 0)
IF(FWRITE(dbf_hndl, dbf_buff, 10);
!= 10)
sndbk = 5
BREAK
ENDIF
buff_cntr = buff_cntr + blcks
NEXT j
NEXT i
END

FCLOSE(dbf_hndl)
FCLOSE(odbt_hndl)

* Calculate string for new next memo block.
ncnt4 = INT(buff_cntr / 16777216)
buff_cntr = buff_cntr - (ncnt4 * 16777216)
ncnt3 = INT(buff_cntr / 65536)
buff_cntr = buff_cntr - (ncnt3 * 65536)
ncnt2 = INT(buff_cntr / 256)
ncnt1 = buff_cntr - (ncnt2 * 256)
dbt_buff = CHR(ncnt1) + CHR(ncnt2) + ;
CHR(ncnt3) + CHR(ncnt4)

* Move to beginning of new DBT and write next
* block string.
FSEEK(ndbt_hndl, 0, 0)
IF(FWRITE(ndbt_hndl, dbt_buff, 4) != 4)
sndbk = 5
ENDIF
FCLOSE(ndbt_hndl)
IF(sndbk == 0) && Got through with no
** errors.
ERASE &dbt_name. && Delete old DBT file.
ERASE &dbf_name. && Delete old DBF file.
ERASE temp.dbt && Delete old DBT file
** copy.
* Rename new DBT file.
RENAME newdbt.dbt TO &dbt_name.
* Rename new DBF file.
RENAME temp.dbf TO &dbf_name.

ELSE
ERASE temp.dbt && Delete working copy
** of DBT file.
ERASE temp.dbf && Delete working copy
** of DBF file.
ERASE newdbt.dbt && Delete new copy of DBT
** file.
ENDIF
RETURN(sndbk)


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0305.ZIP
Filename : MEMOPACK.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/