home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 12 / CD_ASCQ_12_0294.iso / maj / 659 / basicsrc / bb_cai10.bas next >
BASIC Source File  |  1993-08-03  |  12KB  |  440 lines
  1.  
  2. DEFINT A-Z
  3.  
  4. REM $INCLUDE: 'BULLET.BI'
  5. 'bb_cai10.bas 31-May-92 chh
  6. '--example using 8-char key, dups and
  7. '--a second index of LONG INT (on SSN field), dups allowed for this example
  8.  
  9. 'this code is for a simplistic database
  10. 'it uses a single DBF (true DBF-compat) and two related indexes
  11. 'the first index is on the first 5 chars of last name + first char first name
  12. 'second index is on the SSN, since it's a valid LONG INT we use that key type
  13.  
  14. 'C>bc bb_cai10 /o;
  15. 'C>link bb_cai10,,nul,bullet;
  16.  
  17. UseDir$ = ".\"                  'all files use this directory except
  18.                                 'the reindex work file which uses the
  19.                                 'SET TMP= directory or the current directory
  20. CLS
  21. PRINT "BB_CAI10.BAS - 8-CHAR (DUPS) and LONG INT (DUPS), add/reindex example"
  22. PRINT "--maintains *2* index files automatically, using NLS sorting."
  23. PRINT ">> USING DIRECTORY "; UseDir$
  24. PRINT
  25.  
  26. TYPE TestRecTYPE
  27. Tag AS STRING * 1
  28. FirstName AS STRING * 15        'a DBF C fieldtype
  29. LastName AS STRING * 19         'C
  30. SSN AS STRING * 9               'N (use C instead to use SUBSTR() on it)
  31. BDate AS STRING * 8             'D
  32. DeptNo AS STRING * 3            'C
  33. Salary AS STRING * 9            'N
  34. END TYPE '64                    'DBF III+ limit is 4000 bytes/128 fields
  35.                                 
  36. DIM DFP AS DOSFilePack
  37. DIM MP AS MemoryPack
  38. DIM IP AS InitPack
  39. DIM EP AS ExitPack
  40. DIM CDP AS CreateDataPack
  41. DIM CKP AS CreateKeyPack
  42. DIM OP AS OpenPack
  43. DIM AP(1 TO 2) AS AccessPack    '2 since we're maintaining 2 index files
  44.  
  45. DIM FieldList(1 TO 6) AS FieldDescTYPE
  46. DIM TestRec AS TestRecTYPE
  47. DIM ZSTR AS STRING * 1
  48. DIM NameDAT AS STRING * 80      'DBF data file
  49. DIM NameIX1 AS STRING * 80      'first index file
  50. DIM NameIX2 AS STRING * 80      'second index file
  51. DIM KX1 AS STRING * 136         'key expression for first index file
  52. DIM KX2 AS STRING * 136         'key expression for second index file
  53. DIM KeyBuffer AS STRING * 64
  54.  
  55. DIM First$(1 TO 26)
  56. DIM Last$(1 TO 26)
  57. GOSUB FillNamesIn
  58.  
  59. ZSTR = CHR$(0)
  60. NameDAT = UseDir$ + "CHARTEST.DBF" + ZSTR
  61. NameIX1 = UseDir$ + "CHARTEST.IX1" + ZSTR
  62. NameIX2 = UseDir$ + "CHARTEST.IX2" + ZSTR
  63.  
  64. FieldList(1).FieldName = "FIRSTNAME" + ZSTR
  65. FieldList(1).FieldType = "C"
  66. FieldList(1).FieldLength = CHR$(15)
  67. FieldList(1).FieldDC = CHR$(0)
  68. FieldList(2).FieldName = "LASTNAME" + ZSTR + ZSTR
  69. FieldList(2).FieldType = "C"
  70. FieldList(2).FieldLength = CHR$(19)
  71. FieldList(2).FieldDC = CHR$(0)
  72. FieldList(3).FieldName = "SSN" + STRING$(7, 0)
  73. FieldList(3).FieldType = "N"
  74. FieldList(3).FieldLength = CHR$(9)
  75. FieldList(3).FieldDC = CHR$(0)
  76. FieldList(4).FieldName = "BDATE" + STRING$(5, 0)
  77. FieldList(4).FieldType = "D"
  78. FieldList(4).FieldLength = CHR$(8)
  79. FieldList(4).FieldDC = CHR$(0)
  80. FieldList(5).FieldName = "DEPTNO" + STRING$(4, 0)
  81. FieldList(5).FieldType = "C"
  82. FieldList(5).FieldLength = CHR$(3)
  83. FieldList(5).FieldDC = CHR$(0)
  84. FieldList(6).FieldName = "SALARY" + STRING$(4, 0)
  85. FieldList(6).FieldType = "N"
  86. FieldList(6).FieldLength = CHR$(9)
  87. FieldList(6).FieldDC = CHR$(2)
  88.  
  89. level = 100
  90. MP.Func = MemoryXB
  91. stat = BULLET(MP)
  92. IF MP.Memory < 140000 THEN
  93.     QBheap& = SETMEM(-150000)       'hog wild, 64K would do okay
  94.     MP.Func = MemoryXB
  95.     stat = BULLET(MP)
  96.     IF MP.Memory < 140000 THEN stat = 8: GOTO Abend
  97. END IF
  98.  
  99. level = 110
  100. IP.Func = InitXB
  101. IP.JFTmode = 0
  102. stat = BULLET(IP)
  103. IF stat THEN GOTO Abend
  104.  
  105. level = 120
  106. EP.Func = AtExitXB
  107. stat = BULLET(EP)
  108.  
  109. level = 130
  110. DFP.Func = DeleteFileDOS
  111. DFP.FilenamePtrOff = VARPTR(NameDAT)
  112. DFP.FilenamePtrSeg = VARSEG(NameDAT)
  113. stat = BULLET(DFP)
  114. DFP.FilenamePtrOff = VARPTR(NameIX1)
  115. DFP.FilenamePtrSeg = VARSEG(NameIX1)
  116. stat = BULLET(DFP)
  117. DFP.FilenamePtrOff = VARPTR(NameIX2)
  118. DFP.FilenamePtrSeg = VARSEG(NameIX2)
  119. stat = BULLET(DFP)
  120.  
  121. level = 1000
  122. CDP.Func = CreateDXB
  123. CDP.FilenamePtrOff = VARPTR(NameDAT)
  124. CDP.FilenamePtrSeg = VARSEG(NameDAT)
  125. CDP.NoFields = 6
  126. CDP.FieldListPtrOff = VARPTR(FieldList(1))
  127. CDP.FieldListPtrSeg = VARSEG(FieldList(1))
  128. CDP.FileID = 3
  129. stat = BULLET(CDP)
  130. IF stat THEN GOTO Abend
  131.  
  132. level = 1010
  133. OP.Func = OpenDXB
  134. OP.FilenamePtrOff = VARPTR(NameDAT)
  135. OP.FilenamePtrSeg = VARSEG(NameDAT)
  136. OP.ASmode = ReadWrite + DenyNone
  137. stat = BULLET(OP)
  138. IF stat THEN GOTO Abend
  139. HandDAT = OP.Handle
  140.  
  141. level = 1100
  142. KX1 = "SUBSTR(LASTNAME,1,5)+SUBSTR(FIRSTNAME,1,1)"
  143. CKP.Func = CreateKXB
  144. CKP.FilenamePtrOff = VARPTR(NameIX1)
  145. CKP.FilenamePtrSeg = VARSEG(NameIX1)
  146. CKP.KeyExpPtrOff = VARPTR(KX1)
  147. CKP.KeyExpPtrSeg = VARSEG(KX1)
  148. CKP.XBlink = HandDAT
  149. CKP.KeyFlags = cCHAR
  150. CKP.CodePageID = -1
  151. CKP.CountryCode = -1
  152. CKP.CollatePtrOff = 0
  153. CKP.CollatePtrSeg = 0
  154. stat = BULLET(CKP)
  155. IF stat THEN GOTO Abend
  156.  
  157. level = 1102
  158. KX2 = "SSN"
  159. CKP.Func = CreateKXB
  160. CKP.FilenamePtrOff = VARPTR(NameIX2)
  161. CKP.FilenamePtrSeg = VARSEG(NameIX2)
  162. CKP.KeyExpPtrOff = VARPTR(KX2)
  163. CKP.KeyExpPtrSeg = VARSEG(KX2)
  164. CKP.XBlink = HandDAT
  165. CKP.KeyFlags = cLONG
  166. CKP.CodePageID = -1
  167. CKP.CountryCode = -1
  168. CKP.CollatePtrOff = 0
  169. CKP.CollatePtrSeg = 0
  170. stat = BULLET(CKP)
  171. IF stat THEN GOTO Abend
  172.  
  173. level = 1110
  174. OP.Func = OpenKXB
  175. OP.FilenamePtrOff = VARPTR(NameIX1)
  176. OP.FilenamePtrSeg = VARSEG(NameIX1)
  177. OP.ASmode = ReadWrite + DenyNone
  178. OP.xbHandle = HandDAT
  179. stat = BULLET(OP)
  180. IF stat THEN GOTO Abend
  181. HandIX1 = OP.Handle
  182.  
  183. level = 1112
  184. OP.Func = OpenKXB
  185. OP.FilenamePtrOff = VARPTR(NameIX2)
  186. OP.FilenamePtrSeg = VARSEG(NameIX2)
  187. OP.ASmode = ReadWrite + DenyNone
  188. OP.xbHandle = HandDAT
  189. stat = BULLET(OP)
  190. IF stat THEN GOTO Abend
  191. HandIX2 = OP.Handle
  192.  
  193. AP(1).Func = AddRecordXB
  194. AP(1).Handle = HandDAT
  195. AP(1).RecPtrOff = VARPTR(TestRec)
  196. AP(1).RecPtrSeg = VARSEG(TestRec)
  197. AP(1).KeyPtrOff = VARPTR(KeyBuffer)
  198. AP(1).KeyPtrSeg = VARSEG(KeyBuffer)
  199. AP(1).NextPtrOff = VARPTR(AP(2))
  200. AP(1).NextPtrSeg = VARSEG(AP(2))
  201. AP(2).Func = AddRecordXB
  202. AP(2).Handle = HandDAT
  203. AP(2).RecPtrOff = VARPTR(TestRec)
  204. AP(2).RecPtrSeg = VARSEG(TestRec)
  205. AP(2).KeyPtrOff = VARPTR(KeyBuffer)
  206. AP(2).KeyPtrSeg = VARSEG(KeyBuffer)
  207. AP(2).NextPtrOff = 0
  208. AP(2).NextPtrSeg = 0
  209.  
  210. level = 1200
  211. INPUT "Recs to add/reindex:"; Recs2Add&
  212. PRINT "Adding"; Recs2Add&; "records...";
  213.  
  214. 'these are not key values so just make them constant for this example
  215.  
  216. TestRec.Tag = " "
  217. TestRec.BDate = "19331122"   'yes, everyone is the same age
  218. TestRec.DeptNo = "001"       'yes, same dept too
  219. TestRec.Salary = "125000.77" 'and even the same salary
  220.  
  221. GOSUB StartTimer
  222. FOR recs& = 1 TO Recs2Add&
  223.    RandLN = 1 + (25 * RND)
  224.    RandFN = 1 + (25 * RND)
  225.    TestRec.FirstName = First$(RandLN)
  226.    TestRec.LastName = Last$(RandFN)
  227.    TestRec.SSN = LTRIM$(STR$(100000000 + (899999999 * RND)))
  228.    stat = BULLET(AP(1))
  229.    IF stat THEN GOTO Abend
  230. NEXT
  231. GOSUB EndTimer
  232. PRINT secs&; "secs."
  233.  
  234. level = 1210                            'could also reindex separately
  235. PRINT "Reindexing BOTH index files... ";
  236. AP(1).Func = ReindexXB
  237. AP(2).Func = ReindexXB
  238. AP(1).Handle = HandIX1
  239. AP(2).Handle = HandIX2
  240. GOSUB StartTimer
  241. sidx = BULLET(AP(1))
  242. IF sidx THEN stat = AP(sidx).stat
  243. IF stat THEN PRINT "on index"; sidx: GOTO Abend
  244. GOSUB EndTimer
  245. PRINT secs&; "secs."
  246.  
  247. level = 1300
  248. AP(1).Func = GetFirstXB
  249. stat = BULLET(AP(1))
  250. PRINT
  251. PRINT "Using key expression: "; RTRIM$(KX1)
  252. PRINT
  253. PRINT "...the first 5 keys/recs for first index file "
  254. CIX = 1: GOSUB DispRecord
  255. FOR i = 1 TO 4
  256.    IF stat THEN EXIT FOR
  257.    AP(1).Func = GetNextXB
  258.    stat = BULLET(AP(1))
  259.    GOSUB DispRecord
  260. NEXT
  261. IF stat = 202 THEN stat = 0
  262. IF stat THEN GOTO Abend
  263. PRINT
  264.  
  265. level = 1310
  266. AP(1).Func = GetLastXB
  267. stat = BULLET(AP(1))
  268. PRINT "...the last 5 keys/recs for first index file "
  269. CIX = 1: GOSUB DispRecord
  270. FOR i = 1 TO 4
  271.    IF stat THEN EXIT FOR
  272.    AP(1).Func = GetPrevXB
  273.    stat = BULLET(AP(1))
  274.    GOSUB DispRecord
  275. NEXT
  276. IF stat THEN GOTO Abend
  277. PRINT
  278. PRINT "* Press any key to see first/last 5 for SECOND index file";
  279. DO: LOOP UNTIL LEN(INKEY$)
  280. LOCATE , 1
  281.  
  282. level = 1302
  283. AP(2).Func = GetFirstXB
  284. stat = BULLET(AP(2))
  285. PRINT SPACE$(79);
  286. LOCATE , 1
  287. PRINT "Using key expression: "; RTRIM$(KX2)
  288. PRINT
  289. PRINT "...the first 5 keys/recs for second index file "
  290. CIX = 2: GOSUB DispRecord
  291. FOR i = 1 TO 4
  292.    IF stat THEN EXIT FOR
  293.    AP(2).Func = GetNextXB
  294.    stat = BULLET(AP(2))
  295.    GOSUB DispRecord
  296. NEXT
  297. IF stat = 202 THEN stat = 0
  298. IF stat THEN GOTO Abend
  299. PRINT
  300.  
  301. level = 1312
  302. AP(2).Func = GetLastXB
  303. stat = BULLET(AP(2))
  304. PRINT "...the last 5 keys/recs for second index file "
  305. CIX = 2: GOSUB DispRecord
  306. FOR i = 1 TO 4
  307.    IF stat THEN EXIT FOR
  308.    AP(2).Func = GetPrevXB
  309.    stat = BULLET(AP(2))
  310.    GOSUB DispRecord
  311. NEXT
  312. IF stat THEN GOTO Abend
  313.  
  314. PRINT "Okay."
  315. EndIt:
  316. EP.Func = ExitXB
  317. stat = BULLET(EP)
  318. END
  319.  
  320.  
  321. Abend:
  322. PRINT
  323. PRINT "Error:"; stat; "at level"; level; "while performing ";
  324. SELECT CASE level
  325. CASE IS = 999
  326.    SELECT CASE level
  327.    CASE 100
  328.       PRINT "a memory request of 150K."
  329.    CASE 110
  330.       PRINT "BULLET initialization."
  331.    CASE 120
  332.       PRINT "registering of ExitXB with _atexit."
  333.    CASE ELSE
  334.       PRINT "Preliminaries unknown."
  335.    END SELECT
  336. CASE IS <= 1099
  337.    SELECT CASE level
  338.    CASE 1000
  339.       PRINT "data file create."
  340.    CASE 1010
  341.       PRINT "data file open."
  342.    CASE ELSE
  343.       PRINT "data file unknown."
  344.    END SELECT
  345. CASE IS <= 1199
  346.    SELECT CASE level
  347.    CASE 1100
  348.       PRINT "first index file create."
  349.    CASE 1102
  350.       PRINT "second index file create."
  351.    CASE 1110
  352.       PRINT "first index file open."
  353.    CASE 1112
  354.       PRINT "second index file open."
  355.    CASE ELSE
  356.       PRINT "index file unknown."
  357.    END SELECT
  358. CASE IS <= 1299
  359.    SELECT CASE level
  360.    CASE 1200
  361.       PRINT "adding records."
  362.    CASE 1210
  363.       PRINT "reindexing."
  364.    CASE ELSE
  365.       PRINT "adding unknown."
  366.    END SELECT
  367. CASE IS <= 1399
  368.    SELECT CASE level
  369.    CASE 1300
  370.       PRINT "first index file GetFirst/Next."
  371.    CASE 1302
  372.       PRINT "second index file GetFirst/Next."
  373.    CASE 1310
  374.       PRINT "first index file GetLast/Prev."
  375.    CASE 1312
  376.       PRINT "second index file GetLast/Prev."
  377.    CASE ELSE
  378.       PRINT "Get/unknown."
  379.    END SELECT
  380. CASE ELSE
  381.    PRINT "unknown."
  382. END SELECT
  383. GOTO EndIt
  384.  
  385. '----------
  386. DispRecord:
  387. t$ = SPACE$(79)
  388. MID$(t$, 1, 6) = RIGHT$("     " + LTRIM$(STR$(AP(CIX).Recno)), 6)
  389. MID$(t$, 7, 1) = TestRec.Tag
  390. t2$ = RTRIM$(TestRec.LastName) + ", " + RTRIM$(TestRec.FirstName)
  391. MID$(t$, 8, 30) = t2$
  392. t2$ = MID$(TestRec.SSN, 1, 3) + "-" + MID$(TestRec.SSN, 4, 2) + "-" + MID$(TestRec.SSN, 6, 4)
  393. MID$(t$, 40, 11) = t2$
  394. t2$ = MID$(TestRec.BDate, 5, 2) + "/" + MID$(TestRec.BDate, 7, 2) + "/" + MID$(TestRec.BDate, 3, 2)
  395. MID$(t$, 53, 8) = t2$
  396. MID$(t$, 63, 3) = TestRec.DeptNo
  397. MID$(t$, 68, 9) = TestRec.Salary
  398. PRINT t$
  399. RETURN
  400.  
  401. StartTimer:
  402. DEF SEG = &H40
  403. lb1 = PEEK(&H6C)
  404. hb1 = PEEK(&H6D)
  405. lb2 = PEEK(&H6E)
  406. DEF SEG
  407. stime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  408. RETURN
  409.  
  410. EndTimer:
  411. DEF SEG = &H40
  412. lb1 = PEEK(&H6C)
  413. hb1 = PEEK(&H6D)
  414. lb2 = PEEK(&H6E)
  415. DEF SEG
  416. etime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  417. secs& = ((etime& - stime&) * 10) \ 182
  418. RETURN
  419.  
  420. FillNamesIn:
  421. FOR i = 1 TO 26
  422.    READ F$
  423.    First$(i) = F$ + SPACE$(15)  'space-fill names
  424. NEXT
  425. FOR i = 1 TO 26
  426.    READ L$
  427.    Last$(i) = L$ + SPACE$(19)
  428. NEXT
  429. RETURN
  430.  
  431. DATA "Arturo","Bebe","Clarisa","Diamond","Eve","Franklin","Gweny","Horatio"
  432. DATA "Iggie","Jammal","Kevin","Legs","Michelle","Nova","Obar","Pepi","Quartz"
  433. DATA "Raul","Santa","Thomas","Uve","Vue","Winchester","Xeba","Yve","Zanzi"
  434.  
  435. DATA "Abelson","ABELSON","Charlieson","Deltason","Epsilson","Foxson","Gamson","Hydra"
  436. DATA "Manson","Jumpson","Kiloson","Loxson", "Moonson","Noson","Octson"
  437. DATA "Pepson","Quarterson","Renoson","Salvoson","Tooson","Underson","Vulcanson"
  438. DATA "Weaverson","Xanson","ZENDASON","Zendason"
  439.  
  440.