home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / progbas / qbxdbf10.arj / XDBF1.BAS < prev    next >
Encoding:
BASIC Source File  |  1991-09-30  |  10.4 KB  |  372 lines
  1. DECLARE SUB DoAssignFields (FLA() AS ANY, NoFields%, FieldData$())
  2. DECLARE SUB DoGetFieldDesc (FieldData$())
  3. DECLARE SUB DoGetKeyExpression (keyx$)
  4.  
  5. REM $INCLUDE: 'QBXDBF.BI'
  6.  
  7. DEFINT A-Z
  8.  
  9. 'QBXDBF sample 1
  10. '-read data from an ASCII fixed-length record file
  11. '-create a .DBF data file and index it, incremental or mass reindex
  12. '-count all keys to measure key access time
  13. '-list all records just to look at them
  14.  
  15. '31-Jul-91
  16. 'Cornel Huth
  17. '-----------
  18. '30-Sep-91-chh
  19. 'added /2:drivepath option to use second drive as XDATA1.DAT source
  20.  
  21. '-------------
  22. 'C>bc XDBF1/o;
  23. 'C>link /noe XDBF1+nocom,XDBF1.EXE,nul,QBXDBF
  24. '
  25. 'C>XDBF1 [/I][/NL][/DP]
  26. '/I=do incremental indexing, /NL=no list all
  27. '/DP=delete every other record/pack+reindex
  28. '/2:d:\tmp\ =allow XDATA1.DAT to reside on other drivepath
  29. '
  30. 'common data structure in both the raw and the dbf file
  31. 'doing it this way makes it easier to assign one to the other
  32.  
  33. TYPE CommonRecordTYPE
  34. partno AS STRING * 8
  35. desc AS STRING * 20
  36. cost AS STRING * 8
  37. pkgqty AS STRING * 2
  38. status AS STRING * 1
  39. END TYPE '39
  40.  
  41. 'raw data file FIXED.DAT has this record layout
  42. 'raw data happens to be already sorted, matters not
  43.  
  44. TYPE RawRecordTYPE
  45. info AS CommonRecordTYPE
  46. crlf AS STRING * 2
  47. END TYPE '41
  48. DIM RawRecord AS RawRecordTYPE
  49.  
  50. 'DBF translation of FIXED.DAT record layout
  51.  
  52. TYPE DBFRecordTYPE
  53. tag AS STRING * 1
  54. info AS CommonRecordTYPE
  55. END TYPE '40
  56. DIM DBFRecord AS DBFRecordTYPE
  57.  
  58. cl$ = COMMAND$
  59.  
  60. CLS
  61. nul = VersionDBF(version$)
  62. PRINT "WELCOME TO "; version$; " doing a little dBASE..."
  63.  
  64. 'initialize QBXDBF to 1 key file, 1 data file, max of 5 fields per record
  65.  
  66. NoFields = 5
  67. stat = InitDBF(1, 1, NoFields)
  68. IF stat THEN GOTO Abend
  69.  
  70. 'example of how you could setup the field descriptions
  71. 'here we load the field descriptions into FieldData$() first
  72.  
  73. REDIM FieldData$(1 TO NoFields)
  74. DoGetFieldDesc FieldData$()
  75.  
  76. 'array FLA() is the data that determines how QBXDBF reads a DBF data file
  77. 'here we copy the field info just loaded into FieldData$() to FLA()
  78.  
  79. REDIM FLA(1 TO NoFields) AS DBFFieldListTYPE
  80. DoAssignFields FLA(), NoFields, FieldData$()
  81.  
  82. 'example of how you could get the key expression
  83.  
  84. DoGetKeyExpression keyx$
  85.  
  86. 'create the DBF data file (CATALOG.DBF) based on the field data in FLA()
  87. 'if it exists delete it
  88.  
  89. dbfile$ = "catalog.dbf"
  90. PRINT ".create "; dbfile$
  91. IF FileExists(dbfile$ + CHR$(0)) = -1 THEN KILL dbfile$
  92. stat = CreateDataDBF(dbfile$, NoFields, FLA())
  93. IF stat THEN GOTO Abend
  94.  
  95. 'open the DBF file using QBXDBF file handle dbfile
  96. 'open for compatible mode read/write access
  97.  
  98. PRINT ".use "; dbfile$
  99. dbfile = FreeDataFileDBF: IF dbfile = -1 THEN GOTO Abend
  100. OpenMode = 2
  101. stat = OpenDataDBF(dbfile$, dbfile, OpenMode)
  102. IF stat THEN GOTO Abend
  103.  
  104. 'create the key file (CATALOG.DEX) based on keyx$ and the open CATALOG.DBF
  105. 'if it exists delete it
  106.  
  107. kyfile$ = "catalog.dex"
  108. PRINT ".index on "; keyx$; " to "; kyfile$
  109. IF FileExists(kyfile$ + CHR$(0)) = -1 THEN KILL kyfile$
  110. stat = CreateKeyDBF(kyfile$, keyx$, dbfile)
  111. IF stat THEN GOTO Abend
  112.  
  113. 'open the key file using QBXDBF file handle kyfile
  114. 'open for compatible mode read/write access
  115.  
  116. kyfile = FreeKeyFileDBF: IF kyfile = -1 THEN GOTO Abend
  117. OpenMode = 2
  118. stat = OpenKeyDBF(kyfile$, kyfile, dbfile, OpenMode)
  119. IF stat THEN GOTO Abend
  120.  
  121. 'if you set IndexOn = -1 then indexing occurs concurrently when adding records
  122. 'that is not QBXDBF logic but rather just this program example
  123.  
  124. IndexOn = 0
  125. IF INSTR(cl$, "/I") THEN IndexOn = -1
  126.  
  127. IF IndexOn THEN
  128.    PRINT ".set index to "; kyfile$
  129. ELSE
  130.    PRINT ".set index to"
  131. END IF
  132.  
  133. 'everything's setup to go
  134. 'we could use QBXDBF file I/O like ReadDevice(), DeleteFile(), etc., but
  135. 'for this example BASIC file I/O is used for simplicity
  136.  
  137. drv1 = INSTR(cl$, "/2:")
  138. dpath$ = ""
  139. IF drv1 THEN
  140.    dpath$ = MID$(cl$, drv1 + 3)
  141.    FOR i = 1 TO LEN(dpath$)
  142.       IF MID$(dpath$, i, 1) = " " THEN dpath$ = LEFT$(dpath$, i - 1): EXIT FOR
  143.    NEXT
  144.    IF RIGHT$(dpath$, 1) <> "\" THEN dpath$ = dpath$ + "\"
  145. END IF
  146. rawfile$ = dpath$ + "xdata1.dat"
  147. rawfile = FREEFILE
  148. OPEN rawfile$ FOR BINARY AS rawfile
  149.  
  150. 'setup pointer to DBFRecord
  151.  
  152. DBFRecord.tag = " "     'init deleted tag to 'not deleted' (deleted='*')
  153. vseg = VARSEG(DBFRecord)
  154. voff = VARPTR(DBFRecord)
  155.  
  156. 'read a fixed-length record from raw file and add it to the dbfile
  157.  
  158. PRINT ".append from "; rawfile$
  159. PRINT " Records added";
  160.  
  161. 'preload first raw record
  162.  
  163. s1! = TIMER
  164. GET rawfile, , RawRecord
  165. DO WHILE NOT EOF(rawfile)
  166.  
  167.     'update DBFRecord only with the meaningful data in RawRecord
  168.     'write the DBF record
  169.  
  170.     DBFRecord.info = RawRecord.info
  171.  
  172.     stat = AddRecordDBF(dbfile, vseg, voff, recordno&)
  173.     LOCATE , 15: PRINT recordno&;
  174.     IF stat THEN EXIT DO
  175.  
  176.     'add the key to the index file
  177.     '--although QBXDBF is fast, indexing now would be slower
  178.     '--than doing a ReindexDBF() all at once, as done below
  179.  
  180.     IF IndexOn THEN
  181.        stat = AddKeyDBF(kyfile, recordno&, vseg, voff)
  182.        IF stat THEN EXIT DO
  183.     END IF
  184.  
  185.     'load next raw record
  186.  
  187.     GET rawfile, , RawRecord
  188. LOOP
  189. e1! = TIMER
  190. CLOSE rawfile
  191. PRINT USING " (####.# secs)"; e1! - s1!
  192. IF stat THEN GOTO Abend
  193.  
  194. 'do a fast reindex
  195. 'copy kyfile's structure to reindex$ (delete reindex$ first),
  196. 'reindex dbfile (in this case just index it), close kyfile, delete it,
  197. 'rename reindex$ to kyfile$, then open it as the new kyfile$
  198.  
  199. IF IndexOn = 0 THEN
  200.    PRINT ".set index to "; kyfile$
  201.    PRINT ".reindex";
  202.    reindex$ = "$reindex.$$$"
  203.    IF FileExists(reindex$ + CHR$(0)) = -1 THEN KILL reindex$
  204.    IF stat = 0 THEN stat = CopyKeyStrucDBF(kyfile, reindex$)
  205.    s1! = TIMER
  206.    IF stat = 0 THEN stat = ReIndexDBF(kyfile, dbfile, reindex$)
  207.    e1! = TIMER
  208.    PRINT USING " (####.# secs)"; e1! - s1!
  209.    stat2 = CloseKeyDBF(kyfile)
  210.    IF stat2 = 0 THEN KILL kyfile$
  211.    IF stat2 = 0 THEN NAME reindex$ AS kyfile$
  212.    kyfile = FreeKeyFileDBF: IF kyfile = -1 THEN GOTO Abend
  213.    OpenMode = 2
  214.    stat = OpenKeyDBF(kyfile$, kyfile, dbfile, OpenMode)
  215.    IF stat THEN GOTO Abend
  216. END IF
  217.  
  218. 'delete every other record, then pack+reindex
  219.  
  220. IF INSTR(cl$, "/DP") THEN
  221.    PRINT ".delete for mod(recno(),2)=0"
  222.    PRINT " Records deleted";
  223.    stat = GetFirstDBF(kyfile, dbfile, vseg, voff) 'leave odd records
  224.    DO UNTIL stat
  225.       stat = GetNextDBF(kyfile, dbfile, vseg, voff)
  226.       IF stat = 0 THEN
  227.          stat = GetPositionDBF(kyfile, recno&)
  228.          IF stat = 0 THEN stat = DeleteRecordDBF(dbfile, recno&)
  229.          cnt& = cnt& + 1
  230.          LOCATE , 17: PRINT cnt&;
  231.          IF stat = 0 THEN stat = GetNextDBF(kyfile, dbfile, vseg, voff)
  232.       END IF
  233.    LOOP
  234.  
  235.    'stat=202 is normal in the case above, it means end of file reached
  236.    IF stat = 202 THEN stat = 0
  237.    PRINT
  238.  
  239.    IF stat = 0 THEN
  240.       PRINT ".pack";
  241.       packfile$ = "$datpack.$$$"
  242.       IF FileExists(packfile$ + CHR$(0)) = -1 THEN KILL packfile$
  243.       keyfile$ = "$keypack.$$$"
  244.       IF FileExists(keyfile$ + CHR$(0)) = -1 THEN KILL keyfile$
  245.       s1! = TIMER
  246.       stat = PackDBF(dbfile, kyfile, packfile$, keyfile$)
  247.       e1! = TIMER
  248.       PRINT USING " (####.# secs, includes reindex)"; e1! - s1!
  249.       IF stat = 0 THEN
  250.          stat = CloseDataDBF(dbfile)
  251.          IF stat = 0 THEN KILL dbfile$
  252.          IF stat = 0 THEN NAME packfile$ AS dbfile$
  253.  
  254.          IF stat = 0 THEN stat = CloseKeyDBF(kyfile)
  255.          IF stat = 0 THEN KILL kyfile$
  256.          IF stat = 0 THEN NAME keyfile$ AS kyfile$
  257.  
  258.          IF stat = 0 THEN
  259.             dbfile = FreeDataFileDBF: IF dbfile = -1 THEN GOTO Abend
  260.             OpenMode = 2
  261.             stat = OpenDataDBF(dbfile$, dbfile, OpenMode)
  262.             IF stat THEN GOTO Abend
  263.  
  264.             kyfile = FreeKeyFileDBF: IF kyfile = -1 THEN GOTO Abend
  265.             OpenMode = 2
  266.             stat = OpenKeyDBF(kyfile$, kyfile, dbfile, OpenMode)
  267.             IF stat THEN GOTO Abend
  268.          END IF
  269.       END IF
  270.    END IF
  271. END IF
  272.  
  273. IF stat THEN GOTO Abend
  274.  
  275. 'count all keys of kyfile$
  276. 'this is a measure of index access speed only
  277.  
  278. cnt& = 0&
  279. PRINT ".count"
  280. PRINT " Keys counted";
  281. s1! = TIMER
  282. stat = RetrieveFirst(kyfile, Qkey$, Qrecno&)
  283. DO UNTIL stat
  284.    cnt& = cnt& + 1
  285.    LOCATE , 14: PRINT cnt&;
  286.    stat = RetrieveNext(kyfile, Qkey$, Qrecno&)
  287. LOOP
  288. e1! = TIMER
  289. PRINT USING " (####.# secs)"; e1! - s1!
  290.  
  291. 'stat=202 is normal in the case above, it means end of file reached
  292. IF stat = 202 THEN stat = 0
  293. IF stat THEN GOTO Abend
  294.  
  295. 'list all records of dbfile$ inorder by key
  296.  
  297. IF INSTR(cl$, "/NL") = 0 THEN
  298.    PRINT ".list all"
  299.    PRINT "RECORD  PARTNO-- DESC---------------- COST---- PKGQTY STATUS"
  300.    use$ = " ##### &\      \ \                  \ \      \ \\     \\"
  301.    VIEW PRINT CSRLIN TO 24
  302.  
  303.    DIM check AS DBFRecordTYPE
  304.    check.info.partno = STRING$(8, 0)
  305.  
  306.    stat = GetFirstDBF(kyfile, dbfile, vseg, voff)
  307.    DO UNTIL stat
  308.       nul = GetPositionDBF(kyfile, recno&)
  309.       PRINT USING use$; recno&; DBFRecord.tag; DBFRecord.info.partno; DBFRecord.info.desc; DBFRecord.info.cost; DBFRecord.info.pkgqty; DBFRecord.info.status
  310.  
  311.       IF check.info.partno > DBFRecord.info.partno THEN BEEP: SLEEP
  312.       check.info.partno = DBFRecord.info.partno
  313.  
  314.       stat = GetNextDBF(kyfile, dbfile, vseg, voff)
  315.    LOOP
  316.    VIEW PRINT
  317.    LOCATE 24, 1
  318.    PRINT ".quit";
  319.  
  320.    'stat=202 is normal in the case above, it means end of file reached
  321.    IF stat = 202 THEN stat = 0
  322. END IF
  323.  
  324. Abend:
  325. IF stat THEN
  326.    stat2 = GetXEInfo(class, action, locus)
  327.    PRINT
  328.    PRINT "I/O error"; stat; "occured ( extended info error:"; stat2;
  329.    PRINT "class:"; class; "action:"; action; "locus:"; locus; ")"
  330. END IF
  331.  
  332. 'no stat check on the DBF closes though it would be better to do so
  333.  
  334. stat = CloseDataDBF(dbfile)
  335. stat = CloseKeyDBF(kyfile)
  336. SYSTEM
  337.  
  338. SUB DoAssignFields (FLA() AS DBFFieldListTYPE, NoFields, FieldData$())
  339.  
  340. 'assign the FieldData to FLA()
  341.  
  342. FOR i = 1 TO NoFields
  343.    FLA(i).FieldName = MID$(FieldData$(i), 1, 10)
  344.    FLA(i).FieldType = MID$(FieldData$(i), 12, 1)
  345.    FLA(i).FieldLen = VAL(MID$(FieldData$(i), 14, 2))
  346.    FLA(i).FieldDC = VAL(MID$(FieldData$(i), 17, 1))
  347. NEXT
  348.  
  349. END SUB
  350.  
  351. SUB DoGetFieldDesc (FieldData$())
  352.  
  353. 'in a SUB just for simplicity and clarity
  354. 'fixed-form for simplicity, whatever works for you
  355.  
  356. FieldData$(1) = "PARTNO    /C/08/0"
  357. FieldData$(2) = "DESC      /C/20/0"
  358. FieldData$(3) = "COST      /N/08/2"
  359. FieldData$(4) = "PKGQTY    /N/02/0"
  360. FieldData$(5) = "STATUS    /C/01/0"
  361.  
  362. END SUB
  363.  
  364. SUB DoGetKeyExpression (keyx$)
  365.  
  366. 'just an example
  367.  
  368. keyx$ = "upper(partno)"
  369.  
  370. END SUB
  371.  
  372.