2013-06-19 07:43

     $DEFINE  .F.    0
     $DEFINE  .T.    NOT .F.

     STRUCT dbcont
      memo AS BYTE
      updty AS BYTE
      updtm AS BYTE
      updtd AS BYTE
      nrecs AS LONG
      frecp AS WORD ' First record pointer
      recsize AS WORD
      fill5 AS WORD
      fill6 AS BYTE
      fencr AS BYTE
      filler4 AS STRING*12
      fmdx AS BYTE
      filler3 AS STRING*3
     END STRUCT

     STRUCT flddef
      fname AS STRING*11
      ftype AS STRING*1
      filler AS STRING*4
      flen AS BYTE
      decimals AS BYTE
      fill2 AS STRING*14
     END STRUCT

     STRUCT fldinfo
      name AS STRING*11
      owntype AS STRING*1
      maxlen AS BYTE
      decimals AS BYTE
     END STRUCT
     $INCLUDE "dbtools.inc"
 'Public
     DIM mStru AS QMEMORYSTREAM, fldStr AS QMEMORYSTREAM
     DIM h AS dbCont, f AS fldDef
     DIM openStr AS QFILESTREAM
     DIM openDbf AS STRING*64

'*************
     SUB struinfo(id AS STRING, thistype AS STRING, _
       fullen AS BYTE, point AS BYTE)
'It must be called before of a table creation. Do a call for each field needed
      DIM u AS fldinfo

      u.name=id: u.owntype=thistype: u.maxlen=fullen: u.decimals=point
': u.ownflag= &H00
      mStru.WriteUDT(u)
     END SUB
'-----------

     FUNCTION dbCreate( nameArch AS STRING) AS INTEGER
'USES mStru

      DIM openStr AS QFILESTREAM
      DIM mstream AS QMEMORYSTREAM

      IF mStru.size = 0 THEN
       PRINT "No information available.."
       EXIT FUNCTION
      END IF

      PRINT "dbCreate() called..!!" + " Data ->" +STR$(mStru.size)+ "bytes."

      IF openStr.OPEN(nameArch, fmCreate) = FALSE THEN
       result = FALSE
       EXIT FUNCTION
      END IF

' Fill up "the dictionary"
      DIM now AS STRING*10
      now = DATE$

      DIM h AS dbcont
      DIM thisfld AS flddef
      DIM nflds AS WORD
      DIM u AS fldinfo 'Real info

      h.memo    = &H03 'Let us assume there isn't memos
      h.recsize = 0
      h.nrecs   = 0
      nflds     = mStru.size / SIZEOF(u)
      h.fencr = 0
      h.fmdx = &H00
      mStru.position = 0
      FOR i% = 1 TO nflds
'print "u.name ", u.name
       mStru.readUDT(u)
       WITH thisfld
        .fname    = UCASE$(sz10Convert(u.name))
        .ftype    = u.owntype
        .flen     = u.maxlen
        .decimals = u.decimals
       END WITH

       IF thisfld.ftype = "M" THEN
  'print "Memo field found.."
        h.memo = &H83 'NOTE ..
       END IF

'We cannot write toward openStr until h.memo is certain
       mstream.writeUDT(thisfld) '
       IF thisfld.ftype = "C" THEN
        h.recsize = h.recsize + thisfld.flen + thisfld.decimals*256
       ELSE
        h.recsize = h.recsize + thisfld.flen
       END IF
      NEXT

'Dbf files have a delete caracter ,(*), as first byte of register stream
      h.recsize = h.recsize + 1

      IF h.memo = &H83  THEN
       dbtCreate(REPLACESUBSTR$(nameArch, "dbf", "dbt"))
      END IF

      h.frecp = 32 * (1 + nflds) + 2 'Count bytes H&OD and H&00 too
      PRINT "frecp4 " , h.recsize , "frecp ", h.frecp
'showmessage "frecp " & asc(h.frecp)
      h.updty = VAL( MID$(now, 9,2) )   ' "2003" -> "03"
      h.updtm = VAL( MID$(now, 1,2) )
      h.updtd = VAL( MID$(now, 4,2) )
      h.fmdx = &H00
      WITH openStr
 'Header
       .writeUDT(h)

 ' Struct
       .copyFrom(mstream,0)

 ' Close bytes
       .writeNum(&H000D,2)
       .writeNum(&H1A,1)
      END WITH

'ShowMessage "Ready.."

      mstream.CLOSE
      openStr.CLOSE 'Close the file

'mStru.size = 0 'Empty it
      result = TRUE
     END FUNCTION
'---------------------------

     FUNCTION dbOpen(dbfArc AS STRING, mode AS INTEGER) AS INTEGER
      result = FALSE
'print dbfArc

      IF openStr.OPEN(dbfArc, mode) = FALSE THEN
       PRINT "It can't be open.. " + dbfArc
       EXIT FUNCTION
      END IF

      openStr.ReadUDT(h)
      IF h.memo = &H03 OR h.memo = &H83 THEN
      ELSE
       PRINT "Invalid file format.."
       EXIT FUNCTION
      END IF

      IF h.memo = &H83  THEN
       dbtOpen(REPLACESUBSTR$(dbfArc, "dbf", "dbt"), mode)
      END IF

'Defines.
      openDbf = dbfArc

'Ignore CHR$(&H0D) + CHR$(0)
      fldstr.CopyFrom(openStr, h.frecp-SIZEOF(h)-2) 	'Fields descriptor
      openStr.position = h.frecp 						'Ready for read

      result = TRUE
     END FUNCTION

'-------------------------

     SUB dbClose
      IF h.memo = 0 THEN
       EXIT SUB
      END IF

      IF h.memo = &H83  THEN
       dbtClose
      END IF

      openStr.CLOSE
      h.memo = 0 'A utility flag

'Shrink
      fldStr.size = 0
      openDbf = ""
     END SUB


     FUNCTION hasMemo() AS INTEGER 'Very low level (it isn't a "standard" one.)
      result = (h.memo = &H083)
     END FUNCTION

     FUNCTION dataOffset() AS INTEGER 'Idem
      result = h.frecp
     END FUNCTION


     SUB dbgotop
      openStr.position = h.frecp
     END SUB


     SUB dbgoto(n AS LONG)
      IF n > h.nrecs  THEN   n = h.nrecs
      IF n < 1  THEN  n=1

      openStr.position = (n-1) * (h.recsize) + h.frecp
     END SUB


     FUNCTION recno() AS LONG
      result = 0

      IF (openStr.position - h.frecp) < 0  THEN  EXIT FUNCTION
      result = 1+(openStr.position - h.frecp)/h.recsize
     END FUNCTION


     SUB dbSkip(n AS LONG)
      here& = openStr.position
      there& = openStr.position + n * h.recsize

      IF there& < h.frecp THEN
       openStr.position = h.frecp : EXIT SUB
      END IF
      IF there& > openStr.size THEN
       openStr.position = openStr.size-1 : EXIT SUB
      END IF

'Then.. go
      openStr.position = there&
     END SUB


     SUB dbgobottom
      openStr.position = h.frecp + IIF(h.nrecs = 0, 0, h.nrecs-1) * h.recsize
     END SUB


     FUNCTION bof() AS INTEGER
      result = (openStr.position = h.frecp)
     END FUNCTION


     FUNCTION eof() AS INTEGER
      here& = openStr.position
      openStr.READ(i?) 'A lookahead
      openStr.position = here&

      result = ( i? = &H1A)
     END FUNCTION


     FUNCTION recsize() AS WORD
      result = h.recsize
     END FUNCTION


     FUNCTION reccount() AS LONG 'Also named lastrec()
      result = h.nrecs
     END FUNCTION


     FUNCTION fCount() AS INTEGER
      result = fldStr.size / SIZEOF(f)
     END FUNCTION


     SUB dbAppend
      IF openstr.size = 0  THEN
       EXIT SUB
      END IF

      openStr.position = openStr.size - 1
      openStr.writeStr(STRING$(recsize(), 32), recsize())
      openStr.WriteNUM(&H1A, 1)

'Update
      h.nrecs = h.nrecs + 1

      h.updty = VAL( MID$(DATE$, 9,2) )
      h.updtm = VAL( MID$(DATE$, 1,2) )
      h.updtd = VAL( MID$(DATE$, 4,2) )

      openStr.position = 0
      openStr.writeUDT(h)
      dbgoBottom
     END SUB

'*
     SUB dbZap
      DIM auxStr AS QMEMORYSTREAM

      openStr.position = 0
      h.nrecs=0    'NOTE
      h.updty = VAL( MID$(DATE$, 9,2) )
      h.updtm = VAL( MID$(DATE$, 1,2) )
      h.updtd = VAL( MID$(DATE$, 4,2) )

      openStr.writeUDT(h)

      openStr.position = 0
      auxStr.CopyFrom(openStr, h.frecp)
      auxStr.WriteNUM(&H1A, 1)

      openStr.CLOSE
      KILL openDbf

      openStr.OPEN(OpenDbf, fmCreate)
      openStr.CopyFrom(auxStr, 0)

      openStr.position = openStr.size - 1

      IF h.memo = &H83  THEN
       dbtClose
       dbt$ = REPLACESUBSTR$(openDbf, "dbf", "dbt")

       KILL dbt$
       dbtCreate(dbt$)
       dbtOpen(dbt$, fmOpenReadWrite)
      END IF
     END SUB

'*
     FUNCTION fieldGet( i AS WORD) AS VARIANT
      result = ""
      IF i <= 0 OR i > fCount()  THEN  EXIT FUNCTION

      POS& = openStr.position     'Return point

      fldStr.position = 0
      null$ = openStr.readStr(1)     'Skip this flag

      FOR j__ = 1 TO i
       fldStr.readUDT(f)

       SELECT CASE f.ftype
       CASE "C"
        __lon = f.flen + 256 * f.decimals
       CASE ELSE
        __lon = f.flen
       END SELECT

 'Advance (or get it)
       __r$ = OpenStr.ReadStr(__lon)
      NEXT

      SELECT CASE f.ftype
      CASE "C"
       result = __r$
      CASE "D"
       result = stod(__r$)
      CASE "N"
       result = floatVal(__r$)
      CASE "M"
  'A pointer to register into dbt archive
       result = ""
       IF VAL(__r$) > 0  THEN
        result = memoget( VAL(__r$) )
       END IF
      CASE "L"
  'Logical
       result = IIF( __r$ = "F", .F., .T.)
      END SELECT

      openStr.position= POS&
     END FUNCTION

'**
' This call is tricky (Variant parameters doesn't accept constants)
     SUB fieldput(index AS WORD, $value AS STRING, #value AS SINGLE )
 ' print "Second parameter  "; #value
      IF index <= 0 OR index > fCount()  THEN  EXIT SUB

      POS& = openStr.position
      fldStr.position = 0
      lon?? = 0

      null$ = openStr.ReadStr(1)     'This byte is the "delete" flag ("*")
      __j=0
      DO
  ' Find it
       INC(__j)
       fldStr.ReadUDT(f)

       SELECT CASE f.ftype
       CASE "C"
        lon?? = f.flen + 256 * f.decimals
       CASE ELSE
        lon?? = f.flen

        IF f.ftype = "M" AND #value = FORCE_UPDATE THEN
         currentRecID = VAL( openStr.readStr(lon??) )  'See dbt.inc
         openStr.position = openStr.position - lon??
        END IF
       END SELECT

       IF __j = index  THEN  EXIT DO
       openStr.position = openStr.position + lon??
      LOOP

      SELECT CASE f.ftype
      CASE "C"
  'Justificar a la izquierda
       __s$ = Format$("%-"+STR$(f.flen + 256 * f.decimals)+"s", $value)
      CASE "D"
       __s$ = Format$("%"+STR$(f.flen)+"s", dtos($value))  ' Must be 8
   'print __s$
      CASE "N"
  'format$("%12.2f", 567812.34)
       __s$ = Format$("%"+STR$(f.flen-f.decimals-1)+"."+STR$(f.decimals)+"f", VAL($value))
       __s$ = SPACE$(f.flen-LEN(__s$))+__s$
      CASE "M"
       __s$ = Format$("%10d", memoUpdate($value))
      CASE "L"
       __s$ = IIF(#value = .F., "F", "T")
      END SELECT

      openStr.Write(__s$)
      openStr.position = POS&
     END SUB

'*
'
     FUNCTION fieldname(i AS WORD) AS STRING
      result = ""
      IF i <= 0 OR i > fCount()  THEN  EXIT FUNCTION

      fldstr.position = (i-1) * SIZEOF(f)
      fldstr.readUDT(f)

      result = sz10Unconvert(f.fname)
     END FUNCTION

'*
'
     FUNCTION fieldpos(fldname AS STRING) AS INTEGER
      result = 0
      j__% = 1

      fldstr.position = 0
      DO
       fldstr.readUDT(f)

       IF sz10Uncovert(f.fname)= name  THEN
        result = j__%
        EXIT DO
       END IF

       INC(j__%)
      LOOP
     END FUNCTION

'*
'
     FUNCTION TypeOf( fnum AS WORD) AS STRING
      result = "U"

      IF fnum <= 0 OR fnum > fCount()  THEN  EXIT FUNCTION
      fldStr.position = (fnum - 1) * SIZEOF(f)
      result = f.ftype
     END FUNCTION

'*
'
     FUNCTION DecimalsOf( fnum AS WORD ) AS INTEGER
      result = 0

      IF fnum <= 0 OR fnum > fCount()  THEN  EXIT FUNCTION
      fldStr.position = (fnum - 1) * SIZEOF(f)
      fldstr.ReadUDT(f)
      result = f.decimals
     END FUNCTION

'*
'
     FUNCTION LengthOf( fnum AS WORD ) AS INTEGER
      result = 0

      IF fnum <= 0 OR fnum > fCount()  THEN  EXIT FUNCTION
      fldStr.position = (fnum - 1) * SIZEOF(f)
      fldstr.ReadUDT(f)

      SELECT CASE f.ftype
      CASE "C"
       result = f.flen + 256 * f.decimals
      CASE ELSE
       result = f.flen
      END SELECT
     END FUNCTION

'dbBuffer always point to first byte of current record
     SUB Delete
      POS& = openStr.position
      openStr.WriteStr("*", 1)
      openStr.position = POS&
     END SUB

     SUB Recall
      POS& = openStr.position
      openStr.WriteStr(" ", 1)
      openStr.position = POS&
     END SUB

     FUNCTION dbDeleted AS INTEGER
      POS& = openStr.position
      c$   = openStr.ReadStr(1)
      openStr.position = POS&

      result = ( c$ = "*" )
     END FUNCTION

'*
     SUB dbPack
'It doesn't take argument, current stream is on target
'No memos until multitable management becomes
      DIM buf AS QMEMORYSTREAM

      openStr.position = h.frecp            'We can use here "low level" operations

      count& = 0
      WHILE NOT eof()
       IF NOT dbDeleted()  THEN
        buf.WriteBinStr(openStr.ReadBinStr(h.recsize), h.recsize)  'Save it
        INC count&
       ELSE
        dbSkip 1
       END IF
      WEND

      openStr.position = h.frecp
      openStr.copyFrom(buf, 0)         'Overwrite
      openStr.WriteNUM(&H1A, 1)        'Eof mark

'Update info
      openStr.position = 0
      h.nrecs = count&    'NOTE
      h.updty = VAL( MID$(DATE$, 9,2) )
      h.updtm = VAL( MID$(DATE$, 1,2) )
      h.updtd = VAL( MID$(DATE$, 4,2) )

      openStr.writeUDT(h)
      openStr.position = h.frecp
     END SUB



'*****
     FUNCTION dblocate(key AS VARIANT) AS INTEGER
'It looks for all the fields at the pointed record
      result = .F.
      current& = recno()
      keyType? = VARTYPE(key)

      DIM fvalue AS VARIANT
      FOR i% = 1 TO fCount()
       fvalue = fieldget(i%)

       IF VARTYPE(fvalue) = keyType?  THEN
        SELECT CASE keyType?
        CASE 2        'String
         IF LEN(key) > LEN(fvalue)  THEN
          EXIT FUNCTION
         END IF

         IF INSTR( UCASE$(fvalue), UCASE$(key)) > 0  THEN
          result = .T.
          EXIT FOR             'Found
         END IF

        CASE 0,1
         IF key = fvalue  THEN
          result = .T.
          EXIT FOR             'Found
         END IF
        END SELECT
       END IF
      NEXT

      dbgoto(current&)     'Reset to beginning of register
     END FUNCTION


'*
'
     FUNCTION dbscan(key AS VARIANT, fname AS STRING, mode AS INTEGER) AS INTEGER
'It looks for the suitable field at the pointed record
      result = .F.
      DIM value AS VARIANT

      ftype = typeOf( fname )
      value = fieldget( fieldpos(fname) )

      SELECT CASE mode
      CASE 0                 'Equality
       SELECT CASE ftype
       CASE "N", "D"         'Exact
        IF key = value  THEN
         result = .T.
        END IF
       CASE "C"               'It could be inexact
        IF LEN(key) > LEN(value)  THEN
         EXIT FUNCTION
        END IF

        IF UCASE$(MID$(value, 1, LEN(key))) = UCASE$(Key) THEN
         result = .T.
        END IF
       END SELECT
      CASE ELSE
      END SELECT

     END FUNCTION

'A simple example
     SUB dbCopyto(targetFileName AS STRING, sourceFieldName AS STRING, thisValue AS VARIANT)
'Remember.. openStr is the source. It cannot be touched.
'No memos until Qdbase (or something alike..)
      DIM tmpStr AS QFILESTREAM

      IF NOT tmpStr.OPEN(targetFileName, fmcreate)  THEN
       PRINT "Cannot create target table " + targetFileName
       EXIT SUB
      END IF

      POS& = openStr.position        'Remember
      openStr.position = 0

      tmpStr.CopyFrom(openStr, h.frecp)

      count& = 0
      openStr.position = h.frecp      'Be sure
      WHILE NOT eof()
       IF dbScan(thisValue, sourceFieldname, 0)  THEN
        tmpStr.WriteBinStr(openStr.ReadBinStr(h.recsize), h.recsize)
        INC count&
       ELSE
        dbSkip 1
       END IF
      WEND

'Update target header
      tmpStr.position = 0
      DIM head AS dbCont

      head.nrecs = count&
      head.updty = VAL( MID$(DATE$, 9,2) )
      head.updtm = VAL( MID$(DATE$, 1,2) )
      head.updtd = VAL( MID$(DATE$, 4,2) )
      tmpStr.WriteUDT(head)
      tmpStr.CLOSE            'Done

      openStr.position = POS&
     END SUB

2013-06-19 07:43