Firebird Database Server client module

Share your advanced PureBasic knowledge/code with the community.
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Firebird Database Server client module

Post by the.weavster »

I had some free time today so I created the basis of a module for working with the Firebird database:

mod-fbs-public.pb

Code: Select all

Declare.i Allocate(*sv, dbh)
Declare.i Begin(*sv, dbh)
Declare BindDouble(*bfr, idx, itm.d)
Declare BindFloat(*bfr, idx, itm.f)
Declare.i BindInteger(*bfr, idx, itm)
Declare.i BindNull(*bfr, idx)
Declare.i BindString(*bfr, idx, itm.s)
Declare.i Close(*sv, dbh)
Declare.i Commit(*sv, txh)
Declare.i Connect(*sv, DatabaseAlias$, Username$, Password$, Role$="")
Declare.i FetchNext(*sv, stmt, *sqlda_out)
Declare.i Free(*sv, stmt, *sqlda_out=#Null, *sqlda_in=#Null)
Declare FreeField(*fld.fbField)
Declare.s FieldDate(*fld.fbField)
Declare.d FieldDouble(*fld.fbField)
Declare.f FieldFloat(*fld.fbField)
Declare.i FieldInteger(*fld.fbField)
Declare.q FieldQuad(*fld.fbField)
Declare.s FieldString(*fld.fbField)
Declare.s FieldTime(*fld.fbField)
Declare.s FieldTimeStamp(*fld.fbField)
Declare.s GetError(*sv)
Declare.i GetField(*bfr, idx)
Declare.i GetFieldCount(*bfr)
Declare.i Prepare(*sv, txh, stmt, sql.s)
Declare.i Rollback(*sv, txh)
Declare.i SQLExecute(*sv, dbh, txh, qry.s)
Declare.i SQLExecuteP(*sv, txh, stmt, *sqlda_in)
Declare.i SQLSelect(*sv, txh, stmt, sql.s)
Declare.i SQLSelectP(*sv, txh, stmt, *sqlda_in)
mod-fbs-private.pb

Code: Select all

Declare.i _buffer_size(nFields)
Declare _create_buffers(*sqlda_out, nFields.w)
Declare.i _describe(*sv, stmt, *sqlda_out, nFields.w)
Declare _describe_bind(*sv, stmt, *sqlda_in, nFields.w)
Declare.i _execute(*sv, txh, stmt, *sqlda_in=#Null)
Declare.s _extract_date(nDate.i)
Declare.s _extract_time(nTime.i)
Declare.i _field_string(*fld.fbField)
Declare _free_buffers(*bfr)
Declare.i _position_pointer(nFields)
Declare _new_sqlda(*buffer, nFields.w, isparams=#False)
Declare.w _prepare(*sv, txh, stmt, sql.s)
mod-fbs.pb

Code: Select all

DeclareModule fb  
  ;data type constants
  #FB_SQL_ARRAY     = 540
  #FB_SQL_BLOB      = 520
  #FB_SQL_DATE      = 510
  #FB_SQL_DOUBLE    = 480
  #FB_SQL_D_FLOAT   = 530
  #FB_SQL_FLOAT     = 482
  #FB_SQL_INT64     = 580
  #FB_SQL_LONG      = 496
  #FB_SQL_QUAD      = 550
  #FB_SQL_SHORT     = 500
  #FB_SQL_TEXT      = 452
  #FB_SQL_TIMESTAMP = 510
  #FB_SQL_TYPE_DATE = 570
  #FB_SQL_TYPE_TIME = 560
  #FB_SQL_VARYING   = 448
  #FB_SQL_BOOLEAN   = 32764
  #FB_SQL_NULL      = 32766
  
  ;some other required constants
  ;database parameter buffer constants
  #isc_dpb_version1      = 1
  #isc_dpb_user_name     = 28
  #isc_dpb_password      = 29
  #isc_dpb_sql_role_name = 60
  #isc_dpb_sql_dialect   = 63
  #isc_dpb_lc_ctype      = 48
  ;transaction parameter buffer constants
  #isc_tpb_concurrency   = 2
  #isc_tpb_version3      = 3
  #isc_tpb_wait          = 6
  #isc_tpb_write         = 9
  
  #DSQL_CLOSE        = 1
  #DSQL_DROP         = 2
  #SQLDA_VERSION1    = 1
  #FB_SQL_DIALECT_V5 = 1
  #FB_SQL_DIALECT_V6 = 3
  
  Enumeration
    #FB_Client
  EndEnumeration
  
  Structure ISC_STATUS ;used for retrieveing error messages
    vector.i[20]
  EndStructure
  
  Structure XSQLDA Align #PB_Structure_AlignC
    version.w
    sqldaid.b[8]
    sqldabc.l
    sqln.w
    sqld.w
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      wtf.l ; for some reason on 64 bit the first XSQLVAR is offset by 4 bytes?!
    CompilerEndIf
  EndStructure
  
  Structure XSQLVAR Align #PB_Structure_AlignC
    sqltype.w
    sqlscale.w
    sqlsubtype.w
    sqllen.w
    sqldata.i
    sqlind.i
    sqlname_length.w
    sqlname.b[32]
    relname_length.w
    relname.b[32]
    ownname_length.w
    ownname.b[32]
    aliasname_length.w
    aliasname.b[32]
  EndStructure
  
  Structure fbField
    name.s
    type.w
    subtype.w
    size.w
    scale.w
    isnull.w
    length.w
    buffer.i
    pbtype.i
    stringval.s
  EndStructure
  
  Global fbLibrary$
  
  XIncludeFile "mod-fbs-public.pb"
EndDeclareModule

Module fb
  CompilerSelect #PB_Compiler_OS
    CompilerCase #PB_OS_Windows
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
        fbLibrary$ = "fbclient32.dll"
      CompilerElse
        fbLibrary$ = "fbclient64.dll"
      CompilerEndIf
      ; other platforms are as yet untested...
    CompilerCase #PB_OS_Linux
      fbLibrary$ = "libfbclient.so"
    CompilerCase #PB_OS_MacOS
      fbLibrary$ = "Firebird.framework"
  CompilerEndSelect
  
  lResult.i = OpenLibrary(#FB_Client, fbLibrary$)
  If Not lResult
    MessageRequester("Error", "Library not found", 0)
    End
  EndIf
  
  XIncludeFile "mod-fbs-private.pb"
  
  CompilerIf #PB_Compiler_OS = #PB_OS_Windows
    Prototype.i isc_attach_database(*StatusVector, dbNameLength.w, *dbName, *dbHandle, DPBSize.w, *DPB)
    Prototype.i isc_detach_database(*StatusVector, *dbHandle)
    Prototype.i isc_rollback_transaction(*StatusVector, *TransactionHandle)
    Prototype.i isc_commit_transaction(*StatusVector, *TransactionHandle)
    Prototype.i isc_dsql_alloc_statement2(*StatusVector, *dbHandle, *QueryHandle)
    Prototype.i isc_dsql_prepare(*StatusVector, *TransactionHandle, *QueryHandle, SQLlength.w, *SQLstring, Dialect.w, *XSQLDA)
    Prototype.i isc_dsql_describe(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    Prototype.i isc_dsql_describe_bind(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    Prototype.i fb_interpret(*Buffer, SizeOfBuffer.i, *PtrToStatusVector)
    Prototype.i isc_sqlcode(*StatusVector)
    Prototype.i isc_sql_interpret(SQLCode.w, *Buffer, SizeOfBuffer.w)
    Prototype.i isc_dsql_fetch(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    Prototype.i isc_dsql_free_statement(*StatusVector, *QueryHandle, free_option.w)
    Prototype.i isc_dsql_execute_immediate(*StatusVector, *dbHandle, *TransactionHandle, SQL_length.w, *SQLstring, Dialect.w, *XSQLDA)
    Prototype.i isc_dsql_execute(*StatusVector, *TransactionHandle, *QueryHandle, da_version.w, *XSQLDA_IN)
    Prototype.i isc_dsql_execute2(*StatusVector, *TransactionHandle, *QueryHandle, da_version.w, *XSQLDA_IN, *XSQLDA_OUT)
  CompilerElse
    PrototypeC.i isc_attach_database(*StatusVector, dbNameLength.w, *dbName, *dbHandle, DPBSize.w, *DPB)
    PrototypeC.i isc_detach_database(*StatusVector, *dbHandle)
    PrototypeC.i isc_rollback_transaction(*StatusVector, *TransactionHandle)
    PrototypeC.i isc_commit_transaction(*StatusVector, *TransactionHandle)
    PrototypeC.i isc_dsql_alloc_statement2(*StatusVector, *dbHandle, *QueryHandle)
    PrototypeC.i isc_dsql_prepare(*StatusVector, *TransactionHandle, *QueryHandle, SQLlength.w, *SQLstring, Dialect.w, *XSQLDA)
    PrototypeC.i isc_dsql_describe(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    PrototypeC.i isc_dsql_describe_bind(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    PrototypeC.i fb_interpret(*Buffer, SizeOfBuffer.i, *PtrToStatusVector)
    PrototypeC.i isc_sqlcode(*StatusVector)
    PrototypeC.i isc_sql_interpret(SQLCode.w, *Buffer, SizeOfBuffer.w)
    PrototypeC.i isc_dsql_fetch(*StatusVector, *QueryHandle, da_version.w, *XSQLDA)
    PrototypeC.i isc_dsql_free_statement(*StatusVector, *QueryHandle, free_option.w)
    PrototypeC.i isc_dsql_execute_immediate(*StatusVector, *dbHandle, *TransactionHandle, SQL_length.w, *SQLstring, Dialect.w, *XSQLDA)
    PrototypeC.i isc_dsql_execute(*StatusVector, *TransactionHandle, *QueryHandle, da_version.w, *XSQLDA_IN)
    PrototypeC.i isc_dsql_execute2(*StatusVector, *TransactionHandle, *QueryHandle, da_version.w, *XSQLDA_IN, *XSQLDA_OUT)
  CompilerEndIf
  
  ;this is a C pointer on any platform
  PrototypeC.i isc_start_transaction(*StatusVector, *TransactionHandle, Count.w, *dbHandle, TPBLength.w, *TPB)
  
  Global fb_attach.isc_attach_database                   = GetFunction(#FB_Client, "isc_attach_database")
  Global fb_detach.isc_detach_database                   = GetFunction(#FB_Client, "isc_detach_database")
  Global fb_start.isc_start_transaction                  = GetFunction(#FB_Client, "isc_start_transaction")
  Global fb_rollback.isc_rollback_transaction            = GetFunction(#FB_Client, "isc_rollback_transaction")
  Global fb_commit.isc_commit_transaction                = GetFunction(#FB_Client, "isc_commit_transaction")
  Global fb_allocate.isc_dsql_alloc_statement2           = GetFunction(#FB_Client, "isc_dsql_alloc_statement2")
  Global fb_prepare.isc_dsql_prepare                     = GetFunction(#FB_Client, "isc_dsql_prepare") 
  Global fb_describe.isc_dsql_describe                   = GetFunction(#FB_Client, "isc_dsql_describe")
  Global fb_describe_bind.isc_dsql_describe_bind         = GetFunction(#FB_Client, "isc_dsql_describe_bind")
  Global fb_error.fb_interpret                           = GetFunction(#FB_Client, "fb_interpret")
  Global fb_sqlcode.isc_sqlcode                          = GetFunction(#FB_Client, "isc_sqlcode")
  Global fb_sql_error.isc_sql_interpret                  = GetFunction(#FB_Client, "isc_sql_interprete")
  Global fb_fetch.isc_dsql_fetch                         = GetFunction(#FB_Client, "isc_dsql_fetch")
  Global fb_free.isc_dsql_free_statement                 = GetFunction(#FB_Client, "isc_dsql_free_statement")
  Global fb_execute_immediate.isc_dsql_execute_immediate = GetFunction(#FB_Client, "isc_dsql_execute_immediate")
  Global fb_execute.isc_dsql_execute                     = GetFunction(#FB_Client, "isc_dsql_execute")
  Global fb_execute2.isc_dsql_execute2                   = GetFunction(#FB_Client, "isc_dsql_execute2")
  
  Procedure.i _buffer_size(nFields)
    ProcedureReturn (nFields * SizeOf(XSQLVAR)) + SizeOf(XSQLDA) + 20
  EndProcedure  
  
  Procedure _create_buffers(*sqlda_out, nFields.w)
    nPos = *sqlda_out + SizeOf(XSQLDA)
    For c = 1 To nFields
      nSize = PeekW(nPos+OffsetOf(XSQLVAR\sqllen))
      nSize = (nSize * 2) + 4
      bnull = AllocateMemory(8)
      PokeW(bnull, 0)
      bfield = AllocateMemory(nSize)
      PokeI(nPos+OffsetOf(XSQLVAR\sqlind), bnull)
      PokeI(nPos+OffsetOf(XSQLVAR\sqldata), bfield)
      nPos = nPos + SizeOf(XSQLVAR)
    Next
  EndProcedure
  
  Procedure.i _describe(*sv, stmt, *sqlda_out, nFields.w)
    _new_sqlda(*sqlda_out, nFields)
    nResult = fb_describe(*sv, @stmt, 1, *sqlda_out)
    If nResult = 0
      _create_buffers(*sqlda_out, nFields)
      nCheck = PeekW(*sqlda_out+OffsetOf(XSQLDA\sqld))
      ProcedureReturn nCheck
    Else
      ProcedureReturn -1
    EndIf
  EndProcedure
  
  Procedure _describe_bind(*sv, stmt, *sqlda_in, nFields.w)
    _new_sqlda(*sqlda_in, nFields)
    nResult = fb_describe_bind(*sv, @stmt, 1, *sqlda_in)
    If nResult = 0
      _create_buffers(*sqlda_in, nFields)
      nCheck = PeekW(*sqlda_in+OffsetOf(XSQLDA\sqld))
      ProcedureReturn nCheck
    Else
      ProcedureReturn -1
    EndIf    
  EndProcedure
  
  Procedure.i _execute(*sv, txh, stmt, *sqlda_in=#Null)
    ProcedureReturn fb_execute(*sv, @txh, @stmt, #SQLDA_VERSION1, *sqlda_in)
  EndProcedure
  
  Procedure.s _extract_date(nDate.i)
    Define.i nDiff = nDate - 40587 ; fb dates start @ 1858-11-17, PB @ 1970-01-01
    ProcedureReturn FormatDate("%yyyy-%mm-%dd", AddDate(Date(1970,1,1,0,0,0), #PB_Date_Day, nDiff)) 
  EndProcedure
  
  Procedure.s _extract_time(nTime.i)
    Define.i nHours, nMinutes, nSeconds
    Define.s txt = ""
    nHours   = nTime / 36000000 : nTime - (nHours * 36000000)
    txt + Right("00" + Str(nHours), 2) + ":"
    nMinutes = nTime / 600000   : nTime - (nMinutes * 600000)
    txt + Right("00" + Str(nMinutes), 2) + ":"
    nSeconds = nTime / 10000
    txt + Right("00" + Str(nSeconds), 2)
    ProcedureReturn txt
  EndProcedure
  
  Procedure.i _field_string(*fld.fbField)
      Select *fld\type
        Case fb::#FB_SQL_TEXT
          *fld\stringval = PeekS(*fld\buffer, *fld\size, #PB_UTF8)
          *fld\pbtype = #PB_Database_String
        Case fb::#FB_SQL_TEXT + 1
          *fld\stringval = PeekS(*fld\buffer, *fld\size, #PB_UTF8)
          *fld\pbtype = #PB_Database_String
        Case fb::#FB_SQL_VARYING
          *fld\stringval = PeekS(*fld\buffer, -1, #PB_UTF8)
          *fld\pbtype = #PB_Database_String
        Case fb::#FB_SQL_VARYING + 1
          *fld\stringval = PeekS(*fld\buffer, -1, #PB_UTF8)
          *fld\pbtype = #PB_Database_String
        Case fb::#FB_SQL_FLOAT, fb::#FB_SQL_FLOAT + 1
          *fld\stringval = StrF(PeekF(*fld\buffer))
          *fld\pbtype = #PB_Database_Float
        Case fb::#FB_SQL_D_FLOAT, fb::#FB_SQL_D_FLOAT + 1
          *fld\stringval = StrF(PeekF(*fld\buffer))
          *fld\pbtype = #PB_Database_Float
        Case fb::#FB_SQL_DOUBLE, fb::#FB_SQL_DOUBLE + 1
          *fld\stringval = StrD(PeekD(*fld\buffer))
          *fld\pbtype = #PB_Database_Double
        Case fb::#FB_SQL_INT64, fb::#FB_SQL_INT64 + 1, #FB_SQL_QUAD, #FB_SQL_QUAD + 1, #FB_SQL_LONG, #FB_SQL_LONG + 1
          Define.q dRes = 0, dVal = PeekQ(*fld\buffer)
          If *fld\scale = 0
            *fld\stringval = Str(dVal)
            *fld\pbtype = #PB_Database_Quad
          Else
            Define.i nLoop = 0, nDivisor = 1, nScale = *fld\scale * -1
            While nLoop < nScale
              nDivisor * 10
              nLoop + 1
            Wend
            dRes = dVal / nDivisor
            *fld\stringval = StrD(dRes, nScale)
            *fld\pbtype = #PB_Database_Double
          EndIf
        Case fb::#FB_SQL_SHORT, fb::#FB_SQL_SHORT + 1
          *fld\stringval = Str(PeekC(*fld\buffer))
          *fld\pbtype = #PB_Database_Long
        Case fb::#FB_SQL_TIMESTAMP, fb::#FB_SQL_TIMESTAMP + 1
          *fld\stringval = _extract_date(PeekL(*fld\buffer))
          *fld\stringval + " "
          *fld\stringval + _extract_time(PeekL(*fld\buffer+4))
          *fld\pbtype = #Null
        Case fb::#FB_SQL_TYPE_DATE, fb::#FB_SQL_TYPE_DATE + 1
          *fld\stringval = _extract_date(PeekL(*fld\buffer))
          *fld\pbtype = #Null
        Case fb::#FB_SQL_TYPE_TIME, fb::#FB_SQL_TYPE_TIME + 1
          *fld\stringval = _extract_time(PeekL(*fld\buffer))
          *fld\pbtype = #Null
        Default
          *fld\stringval = "Unsupported Type: " + Str(*fld\type)
          *fld\pbtype = #Null
      EndSelect    
    ProcedureReturn *fld
  EndProcedure
  
  Procedure _free_buffers(*bfr)
    nFieldCount = PeekW(*bfr+OffsetOf(XSQLDA\sqld))
    nPos = *bfr + SizeOf(XSQLDA)
    For c = 1 To nFieldCount
      bnull  = PeekI(nPos+OffsetOf(XSQLVAR\sqlind))
      bfield = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
      FreeMemory(bnull)
      FreeMemory(bfield)
      nPos = nPos + SizeOf(XSQLVAR)
    Next
    FreeMemory(*bfr)
  EndProcedure
  
  Procedure.i _position_pointer(nFields)
    nPos = (nFields-1) * SizeOf(XSQLVAR)
    nPos = nPos + SizeOf(XSQLDA)
    ProcedureReturn nPos
  EndProcedure
  
  Procedure _new_sqlda(*buffer, nFields.w, isparams=#False)
    PokeW(*buffer+OffsetOf(XSQLDA\version), #SQLDA_VERSION1)
    PokeS(*buffer+OffsetOf(XSQLDA\sqldaid), "        ", 8, #PB_Ascii)
    PokeL(*buffer+OffsetOf(XSQLDA\sqldabc), 0)
    If isparams
      PokeW(*buffer+OffsetOf(XSQLDA\sqln), 0)
      PokeW(*buffer+OffsetOf(XSQLDA\sqld), nFields)
    Else
      PokeW(*buffer+OffsetOf(XSQLDA\sqln), nFields)
      PokeW(*buffer+OffsetOf(XSQLDA\sqld), 0)
    EndIf
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      PokeL(*buffer+OffsetOf(XSQLDA\wtf), 0)
    CompilerEndIf
  EndProcedure
  
  Procedure.w _prepare(*sv, txh, stmt, sql.s)
    *sqlda_out = AllocateMemory(_buffer_size(1))
    _new_sqlda(*sqlda_out, 1)
    nLen = StringByteLength(sql, #PB_UTF8)
    *sqlbuffer = AllocateMemory(nLen+4)
    PokeS(*sqlbuffer, sql, nLen, #PB_UTF8)
    nResult = fb_prepare(*sv, @txh, @stmt, nLen, *sqlbuffer, #FB_SQL_DIALECT_V6, *sqlda_out)
    FreeMemory(*sqlbuffer)
    nFields.w = -1
    If nResult = 0 
      nFields = PeekW(*sqlda_out+OffsetOf(XSQLDA\sqld))
    EndIf
    FreeMemory(*sqlda_out)
    ProcedureReturn nFields
  EndProcedure
  
  Procedure.i Allocate(*sv, dbh)
    stmt = #Null
    nResult.i = fb_allocate(*sv, @dbh, @stmt)
    If nResult = 0
      ProcedureReturn stmt
    Else
      ProcedureReturn #False
    EndIf
  EndProcedure  
  
  Procedure.i Begin(*sv, dbh)
    *TPB = AllocateMemory(4)
    PokeB(*TPB, #isc_tpb_version3)
    PokeB(*TPB + 1, #isc_tpb_write)
    PokeB(*TPB + 2, #isc_tpb_concurrency)
    PokeB(*TPB + 3, #isc_tpb_wait)
    txh = #Null
    nResult.i = fb_start(*sv, @txh, 1, @dbh, 4, *TPB)
    FreeMemory(*TPB)
    If nResult = 0
      ProcedureReturn txh
    Else
      ProcedureReturn #False   
    EndIf
  EndProcedure
  
  Procedure BindDouble(*bfr, idx, itm.d)
    nPos = *bfr + _position_pointer(idx)
    nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    PokeD(nBfr, itm)
  EndProcedure
  
  Procedure BindFloat(*bfr, idx, itm.f)
    nPos = *bfr + _position_pointer(idx)
    nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    PokeF(nBfr, itm)  
  EndProcedure 
  
  Procedure.i BindInteger(*bfr, idx, itm)
    nPos = *bfr + _position_pointer(idx)
    nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    PokeI(nBfr, itm)   
  EndProcedure
  
  Procedure.i BindNull(*bfr, idx)
    nPos = *bfr + _position_pointer(idx)
    nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqlind))
    PokeW(nBfr, -1) 
  EndProcedure
  
  Procedure.i BindString(*bfr, idx, itm.s)
    nPos = *bfr + _position_pointer(idx)
    nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    nLen.w = StringByteLength(itm, #PB_UTF8)
    PokeW(nBfr, nLen)
    PokeS(nBfr+2, itm, nLen, #PB_UTF8)   
  EndProcedure  
  
  Procedure.i Close(*sv, dbh)
    nResult.i = fb_detach(*sv, @dbh)
    If nResult = 0
      ProcedureReturn #True
    EndIf
    ProcedureReturn #False
  EndProcedure  
  
  Procedure.i Commit(*sv, txh)
    nResult.i = fb_commit(*sv, @txh)
    If nResult.i = 0
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf
  EndProcedure
  
  Procedure.i Connect(*sv, DatabaseAlias$, Username$, Password$, Role$="")
    nAlias.w = StringByteLength(DatabaseAlias$, #PB_UTF8)
    *dbAlias = AllocateMemory(nAlias)
    PokeS(*dbAlias, DatabaseAlias$, nAlias, #PB_UTF8|#PB_String_NoZero)
    Param$ = Chr(#isc_dpb_version1)
    nUN.w = StringByteLength(Username$, #PB_UTF8)
    If nUN > 0 : Param$ + Chr(#isc_dpb_user_name) + Chr(nUN) + Username$  : EndIf
    nPWD.w = StringByteLength(Password$, #PB_UTF8)
    If nPWD > 0 : Param$ + Chr(#isc_dpb_password) + Chr(nPWD) + Password$ : EndIf
    If Role$ <> ""
      nRL.w = StringByteLength(Role$, #PB_UTF8)
      If nRL > 0 : Param$ + Chr(#isc_dpb_sql_role_name) + Chr(nRL) + Role$ : EndIf
    EndIf
    nUN = StringByteLength("UTF8", #PB_UTF8)
    Param$ + Chr(#isc_dpb_lc_ctype) + Chr(nUN) + "UTF8"
    nUN = StringByteLength(Param$, #PB_UTF8)
    *dbParam = UTF8(Param$)
    dbh = #Null
    nResult.i = fb_attach(*sv, nAlias, *dbAlias, @dbh, nUN, *dbParam)
    FreeMemory(*dbAlias)
    FreeMemory(*dbParam)
    If nResult = 0
      ProcedureReturn dbh
    Else
      ProcedureReturn #False
    EndIf
  EndProcedure
  
  Procedure.i FetchNext(*sv, stmt, *sqlda_out)
    ProcedureReturn fb_fetch(*sv, @stmt, 1, *sqlda_out)
  EndProcedure
  
  Procedure.i Free(*sv, stmt, *sqlda_out=#Null, *sqlda_in=#Null)
    If *sqlda_out <> #Null
      _free_buffers(*sqlda_out)
    EndIf
    If *sqlda_in <> #Null
      _free_buffers(*sqlda_in)
    EndIf    
    nRes = fb_free(*sv, @stmt, #DSQL_DROP)
    If nRes = 0
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf
  EndProcedure
  
  Procedure FreeField(*fld.fbField)
    FreeStructure(*fld)
  EndProcedure
  
  Procedure.s FieldDate(*fld.fbField)
    ProcedureReturn *fld\stringval
  EndProcedure
  
  Procedure.d FieldDouble(*fld.fbField)
    ProcedureReturn ValD(*fld\stringval)
  EndProcedure
  
  Procedure.f FieldFloat(*fld.fbField)
    ProcedureReturn ValF(*fld\stringval)
  EndProcedure
  
  Procedure.i FieldInteger(*fld.fbField)
    ProcedureReturn Val(*fld\stringval)
  EndProcedure
  
  Procedure.q FieldQuad(*fld.fbField)
    ProcedureReturn Val(*fld\stringval)
  EndProcedure
  
  Procedure.s FieldString(*fld.fbField)
    ProcedureReturn *fld\stringval
  EndProcedure
  
  Procedure.s FieldTime(*fld.fbField)
    ProcedureReturn *fld\stringval
  EndProcedure
  
  Procedure.s FieldTimeStamp(*fld.fbField)
    ProcedureReturn *fld\stringval
  EndProcedure
  
  Procedure.s GetError(*sv)
    ErrorMessage$ = ""
    nResult.i = 1
    While nResult <> 0
      err = AllocateMemory(256)
      nResult.i = fb_error(err, 256, @*sv)
      ErrorMessage$ + PeekS(err, -1, #PB_UTF8) + #CRLF$
      FreeMemory(err)
    Wend
    If ErrorMessage$ <> ""
      ProcedureReturn ErrorMessage$
    Else
      err = AllocateMemory(256)
      nSQLCode.w = fb_sqlcode(*sv)    
      If nSQLCode <> 0
        ErrorMessage$ = "SQL Code: " + Str(nSQLCode)
        fb_sql_error(nSQLCode, err, 256)
        ErrorMessage$ + #CRLF$ + PeekS(err, -1, #PB_UTF8)
      EndIf
      FreeMemory(err)
      ProcedureReturn ErrorMessage$
    EndIf
  EndProcedure
  
  Procedure.i GetField(*bfr, idx)
    nFieldCount = PeekW(*bfr+OffsetOf(XSQLDA\sqld))
    If idx > nFieldCount
      ProcedureReturn #Null
    EndIf
    nPos = *bfr + _position_pointer(idx)
    nNameLength  = PeekW(nPos+OffsetOf(XSQLVAR\sqlname_length))
    sFieldName.s = PeekS(nPos+OffsetOf(XSQLVAR\sqlname), nNameLength, #PB_UTF8)
    nIsNullP   = PeekI(nPos+OffsetOf(XSQLVAR\sqlind))
    nIsNull.w    = PeekW(nIsNullP)
    *fld.fbField = AllocateStructure(fbField)
    *fld\name    = sFieldName
    *fld\size    = PeekW(nPos+OffsetOf(XSQLVAR\sqllen))
    *fld\scale   = PeekW(nPos+OffsetOf(XSQLVAR\sqlscale))
    *fld\type    = PeekW(nPos+OffsetOf(XSQLVAR\sqltype))
    *fld\subtype = PeekW(nPos+OffsetOf(XSQLVAR\sqlsubtype))
    *fld\buffer  = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    If *fld\type = #FB_SQL_VARYING Or *fld\type = #FB_SQL_VARYING + 1
      *fld\length = PeekW(*fld\buffer)
      *fld\buffer = *fld\buffer + 2
    EndIf
    If nIsNull = 0
      *fld\isnull = #False
    Else
      *fld\isnull = #True
    EndIf
    ProcedureReturn _field_string(*fld)
  EndProcedure
  
  Procedure.i GetFieldCount(*bfr)
    nFieldCount = PeekW(*bfr+OffsetOf(XSQLDA\sqld))
    ProcedureReturn nFieldCount
  EndProcedure
  
  Procedure.i Prepare(*sv, txh, stmt, sql.s)
    nFields = _prepare(*sv, txh, stmt, sql)
    If nFields = -1 : ProcedureReturn #Null : EndIf
    *sqlda_in = AllocateMemory(_buffer_size(1))
    nFields = _describe_bind(*sv, stmt, *sqlda_in, 1)
    If nFields = -1
      FreeMemory(*sqlda_in)
      ProcedureReturn #Null
    Else
      If nFields > 1
        FreeMemory(*sqlda_in)
        *sqlda_in = AllocateMemory(_buffer_size(nFields))
        Res = _describe_bind(*sv, stmt, *sqlda_in, nFields)
        If Res = -1
          ProcedureReturn #Null
        Else
          ProcedureReturn *sqlda_in
        EndIf
      Else
        ProcedureReturn *sqlda_in
      EndIf
    EndIf    
  EndProcedure
  
  Procedure.i Rollback(*sv, txh)
    Res = fb_rollback(*sv, @txh)
    If Res = 0
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf 
  EndProcedure
  
  Procedure.i SQLExecute(*sv, dbh, txh, qry.s)
    nSQL.i = StringByteLength(qry, #PB_UTF8) + 4
    *sql = AllocateMemory(nSQL)
    PokeS(*sql, qry, nSQL, #PB_UTF8)
    Res = fb_execute_immediate(*sv, @dbh, @txh, nSQL, *sql, #FB_SQL_DIALECT_V6, #Null)
    FreeMemory(*sql)
    If Res = 0
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf     
  EndProcedure
  
  Procedure.i SQLExecuteP(*sv, txh, stmt, *sqlda_in)
    Res = _execute(*sv, txh, stmt, *sqlda_in)
    If Res = 0
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf      
  EndProcedure  
  
  Procedure.i SQLSelect(*sv, txh, stmt, sql.s)
    nFields = _prepare(*sv, txh, stmt, sql)
    If nFields = -1 Or nFields = 0 : ProcedureReturn #False : EndIf
    *sqlda_out = AllocateMemory(_buffer_size(nFields))
    Res = _describe(*sv, stmt, *sqlda_out, nFields)
    If Res = -1
      FreeMemory(*sqlda_out)
      ProcedureReturn #False
    EndIf
    If _execute(*sv, txh, stmt) = 0
      ProcedureReturn *sqlda_out
    Else
      FreeMemory(*sqlda_out)
      ProcedureReturn #False
    EndIf
  EndProcedure
  
  Procedure.i SQLSelectP(*sv, txh, stmt, *sqlda_in)
    *sqlda_out = AllocateMemory(_buffer_size(1))
    Res = _describe(*sv, stmt, *sqlda_out, 1)
    If Res = -1
      FreeMemory(*sqlda_out)
      ProcedureReturn #False
    EndIf
    If Res > 1
      FreeMemory(*sqlda_out)
      *sqlda_out = AllocateMemory(_buffer_size(Res))
      Res = _describe(*sv, stmt, *sqlda_out, Res)
      If Res = -1
        FreeMemory(*sqlda_out)
        ProcedureReturn #False
      EndIf
    EndIf
    Res = _execute(*sv, txh, stmt, *sqlda_in)
    If Res = 0
      ProcedureReturn *sqlda_out
    Else
      ProcedureReturn #Null
    EndIf
  EndProcedure   
  
EndModule
And here's an example using the employee demo database that installs with Firebird:

mod-fbs-test.pb

Code: Select all

XIncludeFile "mod-fbs.pb"

Procedure HandleError(*sv,dbh=0,txh=0,stmt=0,*bfr=#Null)
  Debug fb::GetError(*sv)
  If txh  > 0 : fb::Rollback(*sv,txh)   : EndIf
  If stmt > 0 : fb::Free(*sv,stmt,*bfr) : EndIf
  If dbh  > 0 : fb::Close(*sv,dbh)      : EndIf
  End
EndProcedure

sv.fb::ISC_STATUS
dbh = fb::Connect(@sv,"192.168.1.206:employee","sysdba","masterkey")
If Not dbh : HandleError(@sv) : EndIf

txh = fb::Begin(@sv,dbh)
If Not txh : HandleError(@sv,dbh) : EndIf

; do some updates
Res = fb::SQLExecute(@sv,dbh,txh,"UPDATE COUNTRY SET CURRENCY = 'Euro' WHERE COUNTRY = 'Italy'")
If Not Res : HandleError(@sv,dbh,txh) : EndIf

Res = fb::SQLExecute(@sv,dbh,txh,"UPDATE COUNTRY SET CURRENCY = 'Euro' WHERE COUNTRY = 'France'")
If Not Res : HandleError(@sv,dbh,txh) : EndIf

; update with parameters
stmt1 = fb::Allocate(@sv,dbh)
If Not stmt1 : HandleError(@sv,dbh,txh) : EndIf
*sqlda_in = fb::Prepare(@sv,txh,stmt1,"UPDATE COUNTRY SET CURRENCY = ? WHERE COUNTRY = ?")
If Not *sqlda_in : HandleError(@sv,dbh,txh) : EndIf
fb::BindString(*sqlda_in,1,"Euro")
fb::BindString(*sqlda_in,2,"Austria")
Res = fb::SQLExecuteP(@sv,txh,stmt1,*sqlda_in)
If Not Res : HandleError(@sv,dbh,txh,stmt1,*sqlda_in) : EndIf
fb::Free(@sv,stmt1,*sqlda_in)

; select some records and iterate over the recordset
stmt = fb::Allocate(@sv,dbh)
If Not stmt : HandleError(@sv,dbh,txh) : EndIf

*bfr = fb::SQLSelect(@sv,txh,stmt,"SELECT * FROM COUNTRY WHERE CURRENCY = 'Euro' ORDER BY CURRENCY")
If Not *bfr : HandleError(@sv,dbh,txh) : EndIf

recs = 0
nFieldCount = fb::GetFieldCount(*bfr)
Debug "Fields: " + Str(nFieldCount)
nFetch = #True
While nFetch
  Res = fb::FetchNext(@sv,stmt,*bfr)
  If Res = 100
    nFetch = #False
  ElseIf Res <> 0
    HandleError(@sv,dbh,txh,stmt,*bfr)
  Else
    For c = 1 To nFieldCount
      *fld.fb::fbField = fb::GetField(*bfr,c)
      If recs = 0
        Debug ""
        Debug "Name: "   + *fld\name
        Debug "Size: "   + Str(*fld\size)
        Debug "Scale: "  + Str(*fld\scale)
        Debug "Type: "   + Str(*fld\type)
        Debug "Length: " + Str(*fld\length)
      EndIf
      ; you could check *fld\type to know how to Peek but for this example I know it's a string
      Debug *fld\name + ": " + PeekS(*fld\buffer,-1,#PB_UTF8)
      ;Debug "Null: "   + Str(*fld\isnull)
      FreeStructure(*fld)
    Next
    Debug ""
    recs = recs + 1
  EndIf
Wend
fb::Free(@sv,stmt,*bfr)

Debug "Records: " + Str(recs)

; select with parameters
stmt2 = fb::Allocate(@sv,dbh)
If Not stmt2 : HandleError(@sv,dbh,txh) : EndIf
*sqlda_in = fb::Prepare(@sv,txh,stmt2,"SELECT * FROM COUNTRY WHERE CURRENCY = ?")
If Not *sqlda_in : HandleError(@sv,dbh,txh) : EndIf
fb::BindString(*sqlda_in,1,"Pound")

*bfr = fb::SQLSelectP(@sv,txh,stmt2,*sqlda_in)
If Not *bfr : HandleError(@sv,dbh,txh,stmt2,*sqlda_in) : EndIf

nFetch = #True
While nFetch
  Res = fb::FetchNext(@sv,stmt2,*bfr)
  If Res = 100
    nFetch = #False
  ElseIf Res <> 0
    HandleError(@sv,dbh,txh,stmt2,*bfr)
  Else
    For c = 1 To nFieldCount
      *fld.fb::fbField = fb::GetField(*bfr,c)
      Debug *fld\name + ": " + PeekS(*fld\buffer,-1,#PB_UTF8)
      FreeStructure(*fld)
    Next
  EndIf
Wend
fb::Free(@sv,stmt,*bfr,*sqlda_in)

If Not fb::Commit(@sv,txh) : HandleError(@sv,dbh,txh) : EndIf

fb::Close(@sv,dbh)
I've successfully run this example with the 32bit and 64bit client libraries on Windows 10 but not tried on any other platform yet.
If you run it with Firebird Server version < 2.5 you might have issues with encodings other than utf8 but with >= 2.5 hopefully it should just work.

I understand as of v 3.0 Firebird's client library includes the database engine so you can use exactly the same code for accessing a local embedded database as you do for a client/server configuration, the only thing that changes is the initial connection string.

# Edit 2021-10-24: Fixed logic error
Last edited by the.weavster on Sun Dec 04, 2022 3:14 pm, edited 4 times in total.
jackymb
User
User
Posts: 16
Joined: Wed Aug 11, 2004 7:37 pm
Location: AIX en PROVENCE (France)

Re: Firebird Database Server client module

Post by jackymb »

Hi the.weavster,

Thanks for sharing! :D

But I have an error in file: mod-fbs.pb :(

Line 305: UTF8() is not a function, array, list, map or macro

Thanks in advance,
Jacky
Windows 10 x64/86 - PB 5.73LTS (x86 & x64)
_________________________________________
~English is not my native language I'm using a translator~
infratec
Always Here
Always Here
Posts: 6810
Joined: Sun Sep 07, 2008 12:45 pm
Location: Germany

Re: Firebird Database Server client module

Post by infratec »

Hi,

UTF8() was introduced in PB 5.50

But no problem:
Look in the Feature Request section, there is a homemade UTF8() routine in an answer to wilberts request.

http://www.purebasic.fr/english/viewtop ... =3&t=66600

Bernd
jackymb
User
User
Posts: 16
Joined: Wed Aug 11, 2004 7:37 pm
Location: AIX en PROVENCE (France)

Re: Firebird Database Server client module

Post by jackymb »

Hi Infratec,

Thank you for the quick reply.
I installed the PB 5.50, and it works.
I'm going to test my base.

Jacky
Windows 10 x64/86 - PB 5.73LTS (x86 & x64)
_________________________________________
~English is not my native language I'm using a translator~
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

I've updated the code in post #1 as I've now implemented queries with parameters. The only Bind() I've tested so far is BindString(), I need to implement a data type coercion routine and then I think this module will be very usable.

I can also confirm it's working on 64bit Linux as well as 32bit and 64bit Windows.
andreasahlen
New User
New User
Posts: 7
Joined: Fri Jul 06, 2018 10:55 am
Location: Wasserburg am Inn (BY / DE)

Re: Firebird Database Server client module

Post by andreasahlen »

I just tried it with my tables. It works.

Firebird 3.0.7 / PureBasic 5.73 LTS (x64)

Code: Select all

SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') 
             as version from rdb$database;
Thanks for your work @the.weavster

:D
-------
Regards | Saluti | Grüße
Andy
-------
Happy coding :)
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

andreasahlen wrote: Tue Aug 31, 2021 11:15 am Thanks for your work @the.weavster
Thanks for reminding me I made this.
the.weavster wrote:I understand as of v 3.0 Firebird's client library includes the database engine so you can use exactly the same code for accessing a local embedded database as you do for a client/server configuration, the only thing that changes is the initial connection string.
I copied Firebird's example database, EMPLOYEE.FDB, to the local directory, altered the connection string and ran the same code in embedded mode and that did indeed work too :D

When I get some time I might polish this up because being able to swith so effortlessly between an embedded and client/server database is very cool 8)
User avatar
holzhacker
Enthusiast
Enthusiast
Posts: 123
Joined: Mon Mar 08, 2010 9:14 pm
Location: "Mens sana in corpore sano"
Contact:

Re: Firebird Database Server client module

Post by holzhacker »

Hello friends,

I'm having a problem testing this module and I can't solve it. Could you help me?

I created a new database setting the Charset to UTF8, I created a simple test table:

Code: Select all

CREATE TABLE TEST_TABLE
(
   COL1 varchar(25),
   COL2 char(25),
   COL3 decimal (10.2)
);

GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
  ON TEST_TABLE TO SYSDBA WITH GRANT OPTION;

INSERT INTO TEST_TABLE (COL1, COL2, COL3) VALUES ('ÁÉÍÓÚ', 'áéíóú', 19.77);
INSERT INTO TEST_TABLE (COL1, COL2, COL3) VALUES ('ÁÉÍÓÚ_2', 'áéíóú_2', 19.77);
After some tests, I could verify that only CHAR fields are correctly returned, while VARCHAR and DECIMAL type fields, for example, are not.

I appreciate any help as I would like to stop using Firebird with ODBC in my projects,

Thank you very much.

Tests performed with PB 5.73 LTS (x86 and x64), 6.0 Alpha 5 ASM and C backend (x86 and x64)
[editaded] IN TIME: I used the latest version of Flamerobin: https://github.com/mariuz/flamerobin/re ... ag/0.9.3.6 and created a symbolic link to make it work with Firebird 4.0 ( mklink /D "C:\Program Files\ Firebird\Firebird_4_0\bin" "C:\Program Files\Firebird\Firebird_4_0" )
Greetings and thanks!

Romerio Medeiros
romerio@gmail.com
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

Firebird was at version 2.x when I made this module. It still seemed to work with 3.x but not with 4.x
User avatar
holzhacker
Enthusiast
Enthusiast
Posts: 123
Joined: Mon Mar 08, 2010 9:14 pm
Location: "Mens sana in corpore sano"
Contact:

Re: Firebird Database Server client module

Post by holzhacker »

the.weavster wrote: Thu Oct 21, 2021 8:07 pm Firebird was at version 2.x when I made this module. It still seemed to work with 3.x but not with 4.x
Thanks for the reply friend,

I will try with Firebird 3

Do you want to update the module?
Greetings and thanks!

Romerio Medeiros
romerio@gmail.com
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

holzhacker wrote: Thu Oct 21, 2021 10:17 pmDo you want to update the module?
To be honest I probably won't, nowadays I tend to create application servers that expose an api rather than client apps that talk to a database server directly so SQLite gets the job done for me with no setup or admin required.
User avatar
holzhacker
Enthusiast
Enthusiast
Posts: 123
Joined: Mon Mar 08, 2010 9:14 pm
Location: "Mens sana in corpore sano"
Contact:

Re: Firebird Database Server client module

Post by holzhacker »

the.weavster wrote: Fri Oct 22, 2021 9:33 am To be honest I probably won't, nowadays I tend to create application servers that expose an api rather than client apps that talk to a database server directly so SQLite gets the job done for me with no setup or admin required.
I see... I also use SQLite but only as a redundancy. My systems are for markets, bars and restaurants, and due to multiple points of sale and tax requirements around here, I need a server. That's why SQLite is used as a redundancy when the network goes down.

Too bad you can't update this module, I really wanted to use it with FB4.0 and take advantage of the synchronous replication feature.

In the future I will try to study the documentation and fix this problem, which I believe is the length of the content read from the fields which is variable (CHAR has a fixed length and always returns the reserved size for the field and fills the content with blank spaces.)

I will continue using ODBC for now.

As information, I did the tests with FB3.0.7 and its corresponding fbclient.dll, and the problem presented itself again, the only fields successfully returned are the CHAR which has a fixed length, VARCHAR, DECIMAL, among others of variable length are not correctly returned.

Thank you very much for your attention my friend
Greetings and thanks!

Romerio Medeiros
romerio@gmail.com
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

holzhacker wrote: Fri Oct 22, 2021 11:50 amAs information, I did the tests with FB3.0.7 and its corresponding fbclient.dll, and the problem presented itself again, the only fields successfully returned are the CHAR which has a fixed length, VARCHAR, DECIMAL, among others of variable length are not correctly returned.
If you're interested in having a go at fixing yourself...

When you call:

Code: Select all

*fld.fb::fbField = fb::GetField(*bfr, c)
You get a pointer to structure like this:

Code: Select all

*fld\buffer
*fld\name
*fld\type
*fld\size
*fld\scale
*fld\length
So you should be able to use *fld\type to determine which Peek command you should use to get the data at *fld\buffer

From memory Firebird sometimes returns the data type constant + 1 (e.g. fb::#FB_SQL_VARYING + 1) but I can't remember now what the significance of the additional 1 was.

Also from memory decimals are returned as fb::#FB_SQL_INT64 so you peek for a large integer and then *fld\scale tells you how many digits you need to back up to insert the decimal point, so if you have an integer of 1000 and a scale of -2 the decimal is 10.00
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

I've updated the code in the first post and I've tested it against numerous tables in Firebird's example database to make sure the values were being returned correctly. I haven't (yet) implemented BLOB fields (and I'll probably never implement array fields).

I also remembered the significance of the data type constant + 1, the additional one means the field can contain a null.

Here's a new demo that lists all the records in the EMPLOYEE table from the example database that installs with Firebird:

Code: Select all

EnableExplicit
XIncludeFile "mod-fbs.pb"

Procedure HandleError(*sv, dbh=0, txh=0, stmt=0, *bfr=#Null)
  Debug fb::GetError(*sv)
  If txh  > 0 : fb::Rollback(*sv, txh)   : EndIf
  If stmt > 0 : fb::Free(*sv, stmt, *bfr) : EndIf
  If dbh  > 0 : fb::Close(*sv, dbh)      : EndIf
  End
EndProcedure

Define.fb::ISC_STATUS sv
Define.i dbh, txh, stmt, Res, recs, nFieldCount, nFetch

; connect
dbh = fb::Connect(@sv, "127.0.0.1/3050:employee", "sysdba", "masterkey")
If Not dbh : HandleError(@sv) : EndIf

; start a transaction
txh = fb::Begin(@sv, dbh)
If Not txh : HandleError(@sv, dbh) : EndIf

; select some records and iterate over the recordset
stmt = fb::Allocate(@sv, dbh)
If Not stmt : HandleError(@sv, dbh, txh) : EndIf

Define.i *bfr = fb::SQLSelect(@sv, txh, stmt, "SELECT * FROM EMPLOYEE ORDER BY EMP_NO")
If Not *bfr : HandleError(@sv, dbh, txh) : EndIf

recs = 0
nFieldCount = fb::GetFieldCount(*bfr)
Define.i c = 0
Define.fb::fbField *fld

nFetch = #True
While nFetch
  Res = fb::FetchNext(@sv, stmt, *bfr)
  If Res = 100
    nFetch = #False
  ElseIf Res <> 0
    HandleError(@sv, dbh, txh, stmt, *bfr)
  Else
    For c = 1 To nFieldCount
      *fld = fb::GetField(*bfr, c)
      If *fld\isnull
        Debug "#NULL"
      Else
        Select *fld\pbtype
          Case #PB_Database_Double
            Debug fb::FieldDouble(*fld)
          Case #PB_Database_Float
            Debug fb::FieldFloat(*fld)
          Case #PB_Database_Long
            Debug fb::FieldInteger(*fld)
          Case #PB_Database_Quad
            Debug fb::FieldQuad(*fld)
          Case #PB_Database_String
            Debug fb::FieldString(*fld)
          Default
            Select *fld\type
              Case fb::#FB_SQL_TIMESTAMP, fb::#FB_SQL_TYPE_DATE, fb::#FB_SQL_TYPE_TIME
                Debug fb::FieldString(*fld)
              Case fb::#FB_SQL_TIMESTAMP + 1, fb::#FB_SQL_TYPE_DATE + 1, fb::#FB_SQL_TYPE_TIME + 1
                Debug fb::FieldString(*fld)
              Default
                Debug "Unsupported type: " + Str(*fld\type)
            EndSelect
        EndSelect
      EndIf
      fb::FreeField(*fld)
    Next
    Debug ""
    recs = recs + 1
  EndIf
Wend
fb::Free(@sv, stmt, *bfr)

; free the transaction
If Not fb::Commit(@sv, txh) : HandleError(@sv, dbh, txh) : EndIf
fb::Close(@sv, dbh)
.
I have also added a couple of elements to the field structure:

Code: Select all

  Structure fbField
    name.s
    type.w
    subtype.w
    size.w
    scale.w
    isnull.w
    length.w
    buffer.i
    pbtype.i
    stringval.s
  EndStructure
*fld\pbtype holds the most similar PB database constant for a field's data type (e.g. #PB_Database_Double)
*fld\stringval holds a string representation of a fields value, this means you can call fb::FieldString(*fld) even on fields that aren't strings

Firebird's TIMESTAMP field is returned as a string in the format yyyy-mm-dd hh:mm:ss, date and time fields as the relevant subsection.
User avatar
the.weavster
Addict
Addict
Posts: 1531
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

Tested and working (server and embedded) with Firebird 4.0.0 ( tested with PB[C] )
Post Reply