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
      filler AS STRING*20
     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*10
      owntype AS STRING*1
      maxlen AS BYTE
      decimals AS BYTE
     END STRUCT

 'Public
     DIM mStru AS QMEMORYSTREAM
     DIM h AS dbCont
     DIM fldStr AS QMEMORYSTREAM
     DIM f AS fldDef
     DIM openStr AS QFILESTREAM
     DIM openDbf AS STRING*64

'*************
'/1
     FUNCTION szConvert(text AS STRING) AS STRING
      s$ = LEFT$(RTRIM$(text),10)
      result = INSERT$(CHR$(0), s$, LEN(s$)+1)
     END FUNCTION

'/2
     FUNCTION szUnconvert(s AS STRING) AS STRING
      result = LEFT$( s, INSTR(s, CHR$(0))-1 )
     END FUNCTION

'/
     FUNCTION pad(s AS STRING, width AS BYTE) AS STRING
      result = LEFT$( s + SPACE$(width), width)
     END FUNCTION

'/
     FUNCTION dtos(date AS STRING) AS STRING
      result = MID$(date,7)+MID$(date, 4, 2)+MID$(date,1, 2)
     END FUNCTION

'/
     FUNCTION stod(dtos$ AS STRING) AS STRING
      result = MID$(dtos$,7)+"/"+MID$(dtos$,5,2)+"/"+MID$(dtos$,1,4)
     END FUNCTION

'/
     FUNCTION floatVal( number AS STRING) AS SINGLE
      result = 0

      number = LTRIM$(RTRIM$(number))
      IF LEN(number) = 0  OR  VAL(number) = 0   THEN
       EXIT FUNCTION
      END IF

      point? = INSTR(number, ".")

      IF point? > 0  THEN
       decimal$ = MID$(number, point?+1)
       result = VAL( MID$(number, 1, point?-1) )+VAL(decimal$)/10 ^ LEN(decimal$)

      ELSE
       result = VAL(number)
      END IF
     END FUNCTION

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

     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
      mStru.WriteUDT(u)
     END SUB
'-----------

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

      DIM fstream 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 fstream.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)

      mStru.position = 0
      FOR i% = 1 TO nflds
       mStru.readUDT(u)
       WITH thisfld
        .fname    = UCASE$(szConvert(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 can't write to filestream until h.memo would be determined..
       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
      h.updty = VAL( MID$(now, 9,10) )
      h.updtm = VAL( MID$(now, 1,2) )
      h.updtd = VAL( MID$(now, 4,5) )

      WITH fstream
 'Header
       .writeUDT(h)

 ' Struct
       .copyFrom(mstream,0)

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

'ShowMessage "Ready.."

      mstream.CLOSE
      fstream.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)
'openStr.position = openStr.position + n * h.recsize
      here& = openStr.position
      there& = here& + n * h.recsize

      IF there& > (openStr.size-1) THEN ' n > 0
       openStr.position = openStr.size - 1
       EXIT SUB'function
      END IF

      IF there& < h.frecp THEN ' n < 0
       openStr.position = h.frecp
       EXIT SUB'function
      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 IF


     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,10) )
      h.updtm = VAL( MID$(DATE$, 1,2) )
      h.updtd = VAL( MID$(DATE$, 4,5) )

      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,10) )
      h.updtm = VAL( MID$(DATE$, 1,2) )
      h.updtd = VAL( MID$(DATE$, 4,5) )

      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 INTEGER )
 ' 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)+"."+STR$(f.decimals)+"f", #value)
      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 = szUnconvert(f.fname)
     END FUNCTION

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

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

       IF szUncovert(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


'*****
     FUNCTION dblocate(key AS VARIANT) AS INTEGER
      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
         END IF

        CASE 0,1
         IF key = fvalue  THEN
          result = .T.
          EXIT FOR
         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
      result = .F.
      DIM value AS VARIANT

      ftype = typeOf( fname )
      value = fieldget( fieldpos(fname) )
      current& = recno()

      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

2013-06-19 07:43