home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / progbas / qbxdbf10.arj / BT2DBF.BAS < prev    next >
Encoding:
BASIC Source File  |  1991-09-30  |  12.5 KB  |  503 lines
  1. DECLARE FUNCTION GetSetTracker% (recordno&, mode%)
  2. DECLARE FUNCTION GetDeleteLink2% (btHandle%, mode%, link&)
  3. DECLARE SUB DoAbend (msg$, errc%)
  4.  
  5. REM BT2DBF.BAS
  6. REM 31-Jul-91
  7. REM Cornel Huth
  8.  
  9. 'convert a QBTree data file to QBXDBF .DBF data and .DBX index files
  10. 'if you have multiple index files for a data file you need to make
  11. 'changes to this code or just write a routine from scratch using reindex--
  12. '--real easy.
  13.  
  14. 'this isn't pretty but it works
  15.  
  16. REM $INCLUDE: 'QBXDBF.BI'
  17.  
  18. DEFINT A-Z
  19.  
  20. CONST SETRACK = 0
  21. CONST GETRACK = 1
  22.  
  23. TYPE QBTtype
  24. dtype AS STRING * 1
  25. start AS INTEGER
  26. bytes AS INTEGER
  27. END TYPE
  28.  
  29. REDIM SHARED DelTracker(0 TO 32766) AS INTEGER
  30.  
  31. DIM SHARED btHandle AS INTEGER
  32. DIM SHARED btRecLen AS INTEGER
  33. DIM SHARED btAvailList&
  34.  
  35. DIM ReadBuffer AS STRING * 2080
  36. DIM DBFrecord AS STRING * 2048
  37. DIM temp AS STRING * 255
  38.  
  39. rbseg = VARSEG(ReadBuffer)
  40. rboff = VARPTR(ReadBuffer)
  41. dbfseg = VARSEG(DBFrecord)
  42. dbfoff = VARPTR(DBFrecord)
  43.  
  44. OpenMode = 2
  45. dbfile = 0
  46. kyfile = 0
  47.  
  48. CLS
  49. PRINT "BT2DBF ■ QBTree data file to QBXDBF"
  50. PRINT
  51. INPUT "QBTree source file: ", BTS$
  52.  
  53. IF LEN(BTS$) = 0 THEN DoAbend "No source file", 999
  54.  
  55. 'construct base filename
  56.  
  57. dot = INSTR(BTS$, ".")
  58. ldot = dot
  59. DO WHILE dot
  60.    dot = INSTR(dot + 1, BTS$, ".")
  61.    IF dot THEN ldot = dot
  62. LOOP
  63. IF ldot = 1 THEN       '.\FILE
  64.    fbase$ = BTS$
  65. ELSEIF ldot = 2 AND ASC(BTS$) = 46 THEN  '..\FILE
  66.    fbase$ = BTS$
  67. ELSEIF ldot > 2 THEN
  68.    fbase$ = LEFT$(BTS$, ldot - 1)
  69. ELSEIF ldot = 0 AND LEN(BTS$) THEN
  70.    fbase$ = BTS$
  71. ELSE
  72.    fbase$ = "NONAME"
  73. END IF
  74. DBF$ = fbase$ + ".DBF"
  75. DBX$ = fbase$ + ".DBX"
  76. DBT$ = fbase$ + ".$$$"
  77. LOCATE 3, 40
  78. PRINT "QBXDBF out files: "; RIGHT$(fbase$, 13) + ".DBF/.DBX"
  79.  
  80. BTS$ = BTS$ + CHR$(0)
  81.  
  82. 'open the QBTree data file
  83.  
  84. stat = OpenDevice(BTS$, OpenMode, btHandle, btLen&)
  85. IF btLen& > 2048 THEN bytes& = 2048& ELSE bytes& = btLen&
  86.  
  87. IF stat = 0 THEN
  88.    stat = ReadDevice(btHandle, 0&, bytes&, rbseg, rboff)
  89.    IF stat = 0 THEN IF MID$(ReadBuffer, 1, 1) <> "S" THEN stat = 228
  90. END IF
  91. IF stat THEN DoAbend BTS$, stat
  92.  
  93. 'get header info and prompt for number of fields to translate to
  94.  
  95. btRecLen = CVI(MID$(ReadBuffer, 2, 2))
  96. btNoRecs& = CVL(MID$(ReadBuffer, 4, 3) + CHR$(0))
  97. btAvailList& = CVL(MID$(ReadBuffer, 7, 3) + CHR$(0))
  98.  
  99. PRINT "reclen="; btRecLen; " recs="; btNoRecs&;
  100. INPUT ; "  fields= ", btNoFields
  101. IF btNoFields < 1 OR btNoFields > 1023 THEN DoAbend "Bad Field Count", 999
  102. LOCATE 4, 40
  103. PRINT USING "reclen=####"; 0
  104.  
  105. 'allocate the Field List array
  106.  
  107. REDIM FLA(1 TO btNoFields) AS DBFFieldListTYPE
  108. REDIM QBT(1 TO btNoFields) AS QBTtype
  109.  
  110. 'prompt for the field info
  111.  
  112. LOCATE 6, 1
  113. PRINT "Field ---NAME---  TYPE  LEN  DC  QBType  start  bytes ----QBTree Data Rec #1 ---";
  114.  
  115. LOCATE 19, 1
  116. PRINT STRING$(80, 196)
  117. PRINT "NAME=1 to 10 alphanumeric chars only, start with letter, no spaces, _ is valid"
  118. PRINT "TYPE=(C)haracter (N)umeric (D)ate (L)ogical"
  119. PRINT "LEN=C(1-255)  N(1-19)  D(8)=MM/DD/YY  L(1)=T/F or Y/N or blank"
  120. PRINT "DC=dec in N data type(0,2-15) min LEN with DC<>0 is ##.## (LEN=5 DC=2)"
  121. PRINT "QBtype=$ % & ! #, start=byte position in record, bytes=length of $";
  122.  
  123. VIEW PRINT 7 TO 18
  124.  
  125. FOR i = 1 TO btNoFields
  126.    PRINT USING "###"; i;
  127.  
  128. IF0:
  129.    LOCATE , 7
  130.    INPUT ; "", FLA(i).FieldName
  131.    FLA(i).FieldName = UCASE$(FLA(i).FieldName)
  132.    LOCATE , 7
  133.    PRINT FLA(i).FieldName; " ";
  134.    redo = 0
  135.    IF INSTR(RTRIM$(FLA(i).FieldName), " ") THEN GOTO IF0
  136.    IF ASC(FLA(i).FieldName) < 65 THEN GOTO IF0
  137.    FOR j = 1 TO i - 1
  138.       IF FLA(i).FieldName = FLA(j).FieldName THEN redo = -1: EXIT FOR
  139.    NEXT
  140.    IF redo GOTO IF0
  141.  
  142. IF1:
  143.    LOCATE , 21
  144.    INPUT ; "", FLA(i).FieldType
  145.    FLA(i).FieldType = UCASE$(FLA(i).FieldType)
  146.    LOCATE , 21
  147.    PRINT FLA(i).FieldType; " ";
  148.    IF INSTR("CNDL", FLA(i).FieldType) = 0 THEN GOTO IF1
  149.    IF FLA(i).FieldType = "C" THEN FLA(i).FieldDC = 0
  150.    IF FLA(i).FieldType = "L" THEN FLA(i).FieldDC = 0
  151.    IF FLA(i).FieldType = "D" THEN FLA(i).FieldLen = 8: FLA(i).FieldDC = 0
  152.  
  153. IF2:
  154.    LOCATE , 25
  155.    INPUT ; "", FLA(i).FieldLen
  156.    LOCATE , 25
  157.    PRINT FLA(i).FieldLen; " ";
  158.    redo = 0
  159.    SELECT CASE FLA(i).FieldType
  160.    CASE "C"
  161.       IF FLA(i).FieldLen > 255 THEN redo = -1
  162.    CASE "N"
  163.       IF FLA(i).FieldLen > 19 THEN redo = -1
  164.    CASE "D"
  165.       IF FLA(i).FieldLen <> 8 THEN redo = -1
  166.    CASE "L"
  167.       IF FLA(i).FieldLen > 1 THEN redo = -1
  168.    CASE ELSE
  169.    END SELECT
  170.    IF FLA(i).FieldLen < 1 THEN redo = -1
  171.    IF redo THEN GOTO IF2
  172.  
  173. IF3:
  174.    LOCATE , 30
  175.    INPUT ; "", FLA(i).FieldDC
  176.    redo = 0
  177.    SELECT CASE FLA(i).FieldType
  178.    CASE "C", "D", "L"
  179.       FLA(i).FieldDC = 0
  180.    CASE "N"  'simple check only here, consult a dBASE/FOX/Clipper manual for
  181.          'specific limitations, also on N length
  182.       IF FLA(i).FieldDC = 1 THEN redo = -1
  183.    CASE ELSE
  184.    END SELECT
  185.    LOCATE , 30
  186.    PRINT FLA(i).FieldDC; " ";
  187.    IF redo THEN GOTO IF3
  188.  
  189. IF4:
  190.    LOCATE , 36
  191.    INPUT ; "", QBT(i).dtype
  192.    LOCATE , 36
  193.    PRINT QBT(i).dtype; " ";
  194.    IF INSTR("$%&!#", QBT(i).dtype) = 0 THEN GOTO IF4
  195.  
  196. IF5:
  197.    LOCATE , 43
  198.    INPUT ; "", QBT(i).start
  199.    IF QBT(i).start = 0 THEN
  200.       IF i > 1 THEN
  201.      QBT(i).start = QBT(i - 1).start + QBT(i - 1).bytes
  202.       ELSE
  203.      QBT(i).start = 1
  204.       END IF
  205.    END IF
  206.    LOCATE , 43
  207.    PRINT QBT(i).start; " ";
  208.    IF QBT(i).start < 0 OR QBT(i).start > btRecLen THEN GOTO IF5
  209.    IF i > 1 THEN IF QBT(i).start < (QBT(i - 1).start + QBT(i - 1).bytes) THEN GOTO IF5
  210.  
  211. IF6:
  212.    LOCATE , 50
  213.    INPUT ; "", QBT(i).bytes
  214.  
  215.    'enter a -1 at the last prompt to re-enter this field's info
  216.  
  217.    IF QBT(i).bytes = -1 THEN GOTO IF0
  218.  
  219.    redo = 0
  220.    IF QBT(i).start + QBT(i).bytes - 1 > btRecLen THEN GOTO IF5
  221.    SELECT CASE QBT(i).dtype
  222.    CASE "$"
  223.       IF QBT(i).bytes < 1 OR QBT(i).bytes > 255 THEN redo = -1
  224.    CASE "%"
  225.       QBT(i).bytes = 2
  226.    CASE "&", "!"
  227.       QBT(i).bytes = 4
  228.    CASE "#"
  229.       QBT(i).bytes = 8
  230.    CASE ELSE
  231.    END SELECT
  232.    LOCATE , 50
  233.    PRINT QBT(i).bytes; " ";
  234.    IF redo THEN GOTO IF6
  235.  
  236.    'construct this field for first record as an example
  237.  
  238.    temp = MID$(ReadBuffer, 32 + QBT(i).start, QBT(i).bytes)
  239.    LOCATE , 55
  240.    SELECT CASE QBT(i).dtype
  241.    CASE "$"
  242.       PRINT LEFT$(temp, 26)
  243.    CASE "%"
  244.      PRINT CVI(temp)
  245.    CASE "&"
  246.      PRINT CVL(temp)
  247.    CASE "!"
  248.      PRINT CVS(temp)
  249.    CASE "#"
  250.      PRINT CVD(temp)
  251.    CASE ELSE
  252.    END SELECT
  253.  
  254.    old = CSRLIN
  255.    runlen = runlen + FLA(i).FieldLen
  256.    VIEW PRINT
  257.    LOCATE 4, 40
  258.    PRINT USING "reclen=####"; runlen
  259.    VIEW PRINT 7 TO 18
  260.    LOCATE old, 1
  261.  
  262. NEXT
  263.  
  264. VIEW PRINT 20 TO 25
  265. CLS
  266.  
  267.  
  268. 'start up QBXDBF
  269.  
  270. stat = InitDBF(1, 1, btNoFields)
  271. IF stat THEN DoAbend "InitDBF", stat
  272.  
  273. 'create the QBXDBF file
  274.  
  275. stat = CreateDataDBF(DBF$, btNoFields, FLA())
  276. IF stat = 230 THEN
  277.  
  278. IF7:
  279.    LOCATE , 1
  280.    PRINT DBF$; " exists--delete it? (y/n) ";
  281.    ccol = POS(0)
  282.    INPUT ; "", a$
  283.    a$ = LEFT$(UCASE$(a$) + CHR$(0), 1)
  284.    LOCATE , ccol
  285.    PRINT a$; "  ";
  286.    IF INSTR("YN", a$) = 0 THEN GOTO IF7
  287.    PRINT
  288.    IF UCASE$(a$) = "Y" THEN
  289.       stat = DeleteFile(DBF$ + CHR$(0))
  290.       IF stat = 0 THEN stat = CreateDataDBF(DBF$, btNoFields, FLA())
  291.    END IF
  292. END IF
  293. IF stat = 0 THEN stat = OpenDataDBF(DBF$, dbfile, OpenMode)
  294. IF stat THEN DoAbend DBF$, stat
  295.  
  296. PRINT "Example key expression: UPPER(SUBSTR("; RTRIM$(FLA(1).FieldName); ",1,5))+..."
  297. oldLine = CSRLIN
  298.  
  299. 'delete DBF$ partner index
  300.  
  301. IF FileExists(DBX$) = -1 THEN stat = DeleteFile(DBX$ + CHR$(0))
  302.  
  303. IF8:
  304. LOCATE oldLine, 1
  305. LINE INPUT ; "Key expression: "; kx$
  306. stat = CreateKeyDBF(DBX$, kx$, dbfile)
  307. IF stat = 240 THEN
  308.    LOCATE , 1: PRINT SPACE$(79);
  309.    GOTO IF8
  310. END IF
  311. stat = OpenKeyDBF(DBX$, kyfile, dbfile, OpenMode)
  312. IF stat THEN DoAbend "Open " + DBX$, stat
  313. PRINT
  314.  
  315. IF9:
  316. LOCATE , 1
  317. INPUT ; "Skip records marked as deleted? (y/n) ", SkipDel$
  318. SkipDel$ = LEFT$(UCASE$(SkipDel$) + CHR$(0), 1)
  319. LOCATE , 39
  320. PRINT SkipDel$; "  ";
  321. IF INSTR("YN", SkipDel$) = 0 THEN GOTO IF9
  322. PRINT
  323. IF SkipDel$ = "Y" THEN
  324.    LOCATE , 1: PRINT delcnt&; "deleted records found";
  325.    stat = GetDeleteLink2(btHandle, 0, link&)
  326.    DO WHILE stat = 0
  327.       stat = GetDeleteLink2(btHandle, 1, link&)
  328.       IF stat = 0 THEN
  329.      stat = GetSetTracker(link&, SETRACK)
  330.      delcnt& = delcnt& + 1
  331.      LOCATE , 1: PRINT delcnt&; "deleted records found";
  332.       END IF
  333.    LOOP
  334.    PRINT
  335.    IF stat = 202 THEN stat = 0
  336. END IF
  337. IF stat THEN DoAbend "Searching delete list", stat
  338.  
  339. 'read each record from the QBTree data file
  340. 'if it's not deleted then AddRecordDBF()
  341.  
  342. cnt& = 0
  343. recno& = 1
  344. start& = 32&
  345. PRINT "Records added"; cnt&;
  346. DO
  347.    IsDeleted = GetSetTracker(recno&, GETRACK)
  348.    IF IsDeleted = 0 THEN
  349.       start& = 1& * 32 + ((recno& - 1) * btRecLen)
  350.       stat = ReadDevice(btHandle, start&, btRecLen, rbseg, rboff)
  351.       IF stat = 0 THEN
  352.      cnt& = cnt& + 1
  353.      LOCATE , 14: PRINT cnt&;
  354.      MID$(DBFrecord, 1, 1) = " "
  355.      bpos = 2  'skip past delete tag
  356.      FOR i = 1 TO btNoFields
  357.  
  358.          'convert the stuff to what is expected in .DBF format (all ASCII)
  359.  
  360.          SELECT CASE QBT(i).dtype
  361.          CASE "$"
  362.         MID$(DBFrecord, bpos, QBT(i).bytes) = MID$(ReadBuffer, QBT(i).start, QBT(i).bytes)
  363.          CASE "%"
  364.         tint = CVI(MID$(ReadBuffer, QBT(i).start, QBT(i).bytes))
  365.         MID$(DBFrecord, bpos) = MKN$(dbfile, i, CDBL(tint), stat)
  366.          CASE "&"
  367.         tlng& = CVL(MID$(ReadBuffer, QBT(i).start, QBT(i).bytes))
  368.         MID$(DBFrecord, bpos) = MKN$(dbfile, i, CDBL(tlng&), stat)
  369.          CASE "!"
  370.         tsng! = CVS(MID$(ReadBuffer, QBT(i).start, QBT(i).bytes))
  371.         MID$(DBFrecord, bpos) = MKN$(dbfile, i, CDBL(tsng!), stat)
  372.          CASE "#"
  373.         tdbl# = CVD(MID$(ReadBuffer, QBT(i).start, QBT(i).bytes))
  374.         MID$(DBFrecord, bpos) = MKN$(dbfile, i, tdbl#, stat)
  375.          CASE ELSE
  376.          END SELECT
  377.  
  378.          bpos = bpos + FLA(i).FieldLen
  379.  
  380.      NEXT
  381.      stat = AddRecordDBF(dbfile, dbfseg, dbfoff, nul&)
  382.       END IF
  383.    END IF
  384.    recno& = recno& + 1
  385. LOOP WHILE stat = 0
  386. IF stat = -2 THEN stat = 0
  387. IF stat THEN DoAbend "Adding records", stat
  388.  
  389. 'reindex
  390. PRINT
  391. PRINT "Reindexing"
  392. IF FileExists(DBT$) = -1 THEN stat = DeleteFile(DBT$ + CHR$(0))
  393. IF stat = 0 THEN stat = CopyKeyStrucDBF(kyfile, DBT$)
  394. IF stat = 0 THEN
  395.    stat = ReIndexDBF(kyfile, dbfile, DBT$)
  396.    IF stat = 0 THEN
  397.       stat = CloseKeyDBF(kyfile)
  398.       IF stat = 0 THEN
  399.      stat = DeleteFile(DBX$ + CHR$(0))
  400.      IF stat = 0 THEN
  401.         stat = RenameFile(DBT$ + CHR$(0), DBX$ + CHR$(0))
  402.         IF stat = 0 THEN
  403.            stat = OpenKeyDBF(DBX$, kyfile, dbfile, OpenMode)
  404.            IF stat THEN DoAbend "Open " + DBX$, stat
  405.         END IF
  406.      END IF
  407.       END IF
  408.       IF stat THEN DoAbend "DOS I/O", stat
  409.    END IF
  410.    IF stat THEN DoAbend "Reindexing", stat
  411. END IF
  412. IF stat THEN DoAbend "Copy Struc", stat
  413.  
  414. 'take a look at them, what the heck
  415. '2.5 hours, down-n-dirty BASIC
  416.  
  417. PRINT "Records counted";
  418.  
  419. stat = GetFirstDBF(kyfile, dbfile, dbfseg, dbfoff)
  420. cnt& = 0
  421. DO WHILE stat = 0
  422.    cnt& = cnt& + 1
  423.    LOCATE , 16: PRINT cnt&;
  424.    stat = GetNextDBF(kyfile, dbgile, dbfseg, dbfoff)
  425. LOOP
  426. PRINT
  427. PRINT
  428.  
  429. xit:
  430. VIEW PRINT
  431. nul = CloseDevice(btHandle)
  432. stat = ExitDBF
  433. LOCATE 25, 1: PRINT SPACE$(80);
  434. LOCATE 24, 1: PRINT "Done.";
  435. CLEAR
  436. END
  437.  
  438. SUB DoAbend (msg$, errc)
  439.  
  440. VIEW PRINT 20 TO 25
  441. CLS
  442. PRINT "Error:"; errc; "on "; msg$
  443. IF btHandle THEN nul = CloseDevice(btHandle)
  444. nul = ExitDBF
  445. SYSTEM
  446.  
  447. END SUB
  448.  
  449. FUNCTION GetDeleteLink2 (btHandle, mode, link&)
  450.  
  451. 'traverse the deleted records' linked-list
  452. 'mode<>0 then for each time called return in link& the next deleted record-
  453. '-in list, when link& returned as 0 then last link was end of list (stat=202)
  454. 'mode=0  then reinit start link
  455.  
  456. STATIC nextlinkrec&
  457.  
  458. DIM AvailPtr AS STRING * 8
  459.  
  460. IF mode = 0 THEN
  461.    nextlinkrec& = 0&
  462.    link& = 0
  463. ELSE
  464.    IF nextlinkrec& = 0 THEN
  465.       recno& = btAvailList&
  466.       btAvailList& = 0
  467.    ELSE
  468.       recno& = nextlinkrec&
  469.    END IF
  470.    IF recno& <> 0 THEN
  471.       apseg = VARSEG(AvailPtr)
  472.       apoff = VARPTR(AvailPtr)
  473.       start& = 1& * 32 + ((recno& - 1) * btRecLen)
  474.       stat = ReadDevice(btHandle, start&, 3&, apseg, apoff)
  475.       IF stat = 0 THEN nextlinkrec& = CVL(LEFT$(AvailPtr, 3) + CHR$(0))
  476.       GetDeleteLink2 = stat
  477.    ELSE
  478.       GetDeleteLink2 = 202       'return EOF when at last deleted link&
  479.    END IF
  480.    link& = recno&
  481. END IF
  482.  
  483. END FUNCTION
  484.  
  485. FUNCTION GetSetTracker (recordno&, mode)
  486.  
  487. 'bitmap of deleted records, max records supported: 65532*8 = 524,256 recs
  488.  
  489. ndx = (recordno& - 1) \ 16
  490. bmask& = 1& * 2 ^ ((recordno& - 1) MOD 16)
  491. IF bmask& > 32767 THEN bitmask = bmask& - 65536 ELSE bitmask = bmask&
  492.  
  493. IF mode = GETRACK THEN
  494.    IsDeleted = DelTracker(ndx) AND bitmask
  495. ELSE
  496.    DelTracker(ndx) = DelTracker(ndx) OR bitmask
  497.    IsDeleted = 0
  498. END IF
  499. GetSetTracker = IsDeleted
  500.  
  501. END FUNCTION
  502.  
  503.