Interbase & Firebird : Wrapper Problem

[thanos]

[quote="the.weavster"]use:

Code: Select all

fb_OpenDatabase("localhost:F:\My-Applications\Manager\Evolution.fdb", "sysdba", "masterkey")

YES!!!
It is working now
Thank you very much.
You opened the horizons of my VB application.
I will extend it with PureBasic.
If i want to execute a SELECT statement, how can i take the results (rows) into PureBasic application?
Best regards

Thanos

[the.weavster]

If i want to execute a SELECT statement, how can i take the results (rows) into PureBasic application?

It's a little tricky, it involves a bit of peeking and poking. If I get some time over the weekend I'll try to create an example.

[thanos]

If i want to execute a SELECT statement, how can i take the results (rows) into PureBasic application?

It's a little tricky, it involves a bit of peeking and poking. If I get some time over the weekend I'll try to create an example.

You are the best.
Thanks in advance.
Regards.

Thanos

[the.weavster]

You are the best.

Thanks



Here's an example of returning records from a SELECT statement:

Code: Select all

;the.weavster
;2008-12-14

#FB_Client = 1
Global sLibrary.s
Global EndOfLine.s
Global lErrorFunction
Global fb_LastErrorMessage.s
Global fbEncoding_Meta = #PB_Ascii ;I think log ins, column names etc are always in ascii

;- data type constants
#SQL_ARRAY = 540
#SQL_BLOB = 520
#SQL_DATE = 510
#SQL_DOUBLE = 480
#SQL_D_FLOAT = 530
#SQL_FLOAT = 482
#SQL_INT64 = 580
#SQL_LONG = 496
#SQL_QUAD = 550
#SQL_SHORT = 500
#SQL_TEXT = 452
#SQL_TIMESTAMP = 510
#SQL_TYPE_DATE = 570
#SQL_TYPE_TIME = 560
#SQL_VARYING = 448

;some other required constants
;- database parameter buffer constants
#isc_dpb_version1 = 1
#isc_dpb_user_name = 28
#isc_dpb_password = 29
#isc_dpb_sql_dialect = 63
;- 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
#SQL_DIALECT_V5 = 1
#SQL_DIALECT_V6 = 3

;- just some buffer positioning stuff
#fb_Size_XSQLDA = 20
#fb_Size_XSQLVAR = 152
#fb_Offset_Type = 0
#fb_Offset_Scale = 2
#fb_Offset_Size = 6
#fb_Offset_FieldBuffer = 8
#fb_Offset_NullBuffer = 12
#fb_Offset_NameLength = 16
#fb_Offset_Name = 18

#fb_Offset_XSQLVARS_Allocated = 16
#fb_Offset_FieldCount = 18

;- The Firebird api status vector array - used for retrieveing error messages
Structure ISC_STATUS 
  vector.i[20]
EndStructure

;- To hold some properties of our database
Structure fbDatabase
  DatabaseID.i
  Encoding.i
EndStructure
Global NewList fbDB.fbDatabase()

;- To hold some properties of our recordsets
Structure fbRecordSet
  RecordsetID.i
  DatabaseID.i
  TransactionID.i
  QueryID.i
  Query.s
  BufferAddress.i
  BufferSize.i
  FieldCount.i
EndStructure
Global NewList fbRS.fbRecordSet()

;- To hold some properties for each returned field
Structure fbField
  RecordsetID.i
  Index.i
  Name.s
  Type.i
  Size.i
  Scale.i
  IsNull.i
  BufferAddress.i
  BufferSize.i
EndStructure
Global NewList fbFld.fbField()

CompilerSelect #PB_Compiler_OS
  CompilerCase #PB_OS_Windows
    sLibrary.s = "fbclient.dll"
    EndOfLine = Chr(13) + Chr(10)
  CompilerCase #PB_OS_Linux
    sLibrary.s = "libfbclient.so"
    EndOfLine = Chr(10) ;need to check this out
  CompilerCase #PB_OS_MacOS
    sLibrary.s = "Firebird.framework"
    EndOfLine = Chr(10) ;need to check this out
CompilerEndSelect

;------------------------------------------------------------------------
;- Prototypes for the required functions from the Firebird client library
;------------------------------------------------------------------------

Prototype.i isc_attach_database(*StatusVector,dbNameLength.w,*dbName,*dbHandle,DPBSize.w,*DPB)
Global fb_attach.isc_attach_database

Prototype.i isc_detach_database(*StatusVector,*dbHandle)
Global fb_detach.isc_detach_database

PrototypeC.i isc_start_transaction(*StatusVector,*TransactionHandle,Count.w,*dbHandle,TPBLength.w,*TPB)
Global fb_start.isc_start_transaction

Prototype.i isc_rollback_transaction(*StatusVector,*TransactionHandle)
Global fb_rollback.isc_rollback_transaction

Prototype.i isc_commit_transaction(*StatusVector,*TransactionHandle)
Global fb_commit.isc_commit_transaction

Prototype.i isc_dsql_alloc_statement2(*StatusVector,*dbHandle,*QueryHandle)
Global fb_allocate.isc_dsql_alloc_statement2

Prototype.i isc_dsql_prepare(*StatusVector,*TransactionHandle,*QueryHandle,SQLlength.w,*SQLstring,Dialect.w,*XSQLDA)
Global fb_prepare.isc_dsql_prepare

Prototype.i isc_dsql_describe(*StatusVector,*QueryHandle,da_version.w,*XSQLDA)
Global fb_describe.isc_dsql_describe

Prototype.i fb_interpret_old(*Buffer,*PtrToStatusVector)
Global fb_error_old.fb_interpret_old

Prototype.i fb_interpret(*Buffer,SizeOfBuffer.i,*PtrToStatusVector)
Global fb_error.fb_interpret

Prototype.i isc_sqlcode(*StatusVector)
Global fb_sqlcode.isc_sqlcode

Prototype.i isc_sql_interpret(SQLCode.w,*Buffer,SizeOfBuffer.w)
Global fb_sql_error.isc_sql_interpret

Prototype.i isc_dsql_fetch(*StatusVector,*QueryHandle,da_version.w,*Buffer)
Global fb_fetch.isc_dsql_fetch

Prototype.i isc_dsql_free_statement(*StatusVector,*QueryHandle,free_option.w)
Global fb_free.isc_dsql_free_statement

Prototype.i isc_dsql_execute_immediate(*StatusVector,*dbHandle,*TransactionHandle,SQL_length.w,*SQLstring,Dialect.w,*XSQLDA)
Global fb_execute_immediate.isc_dsql_execute_immediate

Prototype.i isc_dsql_execute(*StatusVector,*TransactionHandle,*QueryHandle,da_version.w,*XSQLDA)
Global fb_execute.isc_dsql_execute

If OpenLibrary(#FB_Client,sLibrary)
  fb_attach = GetFunction(#FB_Client,"isc_attach_database")
  fb_detach = GetFunction(#FB_Client,"isc_detach_database")
  fb_start = GetFunction(#FB_Client,"isc_start_transaction")
  fb_rollback = GetFunction(#FB_Client,"isc_rollback_transaction")
  fb_commit = GetFunction(#FB_Client,"isc_commit_transaction")
  fb_allocate = GetFunction(#FB_Client,"isc_dsql_alloc_statement2")
  fb_sqlcode = GetFunction(#FB_Client,"isc_sqlcode")
  fb_sql_error = GetFunction(#FB_Client,"isc_sql_interprete")
  fb_fetch = GetFunction(#FB_Client,"isc_dsql_fetch")
  fb_free = GetFunction(#FB_Client,"isc_dsql_free_statement")
  fb_execute_immediate = GetFunction(#FB_Client,"isc_dsql_execute_immediate")
  fb_execute = GetFunction(#FB_Client,"isc_dsql_execute")
  fb_prepare = GetFunction(#FB_Client,"isc_dsql_prepare")
  fb_describe = GetFunction(#FB_Client,"isc_dsql_describe")  
  If GetFunction(#FB_Client,"fb_interpret") = 0 ;the new error function isn't in the library
    lErrorFunction = 0 ;use the old error function
    fb_error_old = GetFunction(#FB_Client,"isc_interprete")    
  Else
    lErrorFunction = 1 ;use the new error function
    fb_error = GetFunction(#FB_Client,"fb_interpret")
  EndIf  
Else
  MessageRequester("Error","Library not found",0)
  End
EndIf

;--------------------------------------------------------
;- Procedures that have names beginning with xfb_ are all 
;- helper procedures that you don't need to call directly
;--------------------------------------------------------

Procedure.i xfb_dbEncoding(DB_ID)
  ResetList(fbDB())
  While NextElement(fbDB())
    If fbDB()\DatabaseID = DB_ID : ProcedureReturn fbDB()\Encoding : EndIf
  Wend
  ProcedureReturn #PB_UTF8
EndProcedure

Procedure.i xfb_rsEncoding(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID : ProcedureReturn xfb_dbEncoding(fbRS()\DatabaseID) : EndIf
  Wend
  ProcedureReturn #PB_UTF8
EndProcedure

Procedure xfb_InterpretDatabaseError(*sv)
  fb_LastErrorMessage = ""
  lSQLCode.w = fb_sqlcode(*sv)
  If lSQLCode <> 0
    fb_LastErrorMessage = "SQL Code: " + Str(lSQLCode)
    *Mem = AllocateMemory(1000)
    fb_sql_error(lSQLCode,*Mem,1000)

    fb_LastErrorMessage = fb_LastErrorMessage + EndOfLine + PeekS(*Mem,1000,fbEncoding_Meta)
    FreeMemory(*Mem)
  EndIf
  If fb_LastErrorMessage <> "":fb_LastErrorMessage = fb_LastErrorMessage + EndOfLine + EndOfLine:EndIf
  lresult = 1
  If lErrorFunction = 0 ;the old error function
    While lresult <> 0
      *Mem = AllocateMemory(1000)
      lresult = fb_error_old(*Mem,@*sv)
      fb_LastErrorMessage = fb_LastErrorMessage + EndOfLine + PeekS(*Mem,1000,fbEncoding_Meta)
      FreeMemory(*Mem)
    Wend  
  Else ;the new error function
    While lresult <> 0
      *Mem = AllocateMemory(1000)
      lresult = fb_error(*Mem,1000,@*sv)
      fb_LastErrorMessage = fb_LastErrorMessage + EndOfLine + PeekS(*Mem,1000,fbEncoding_Meta)
      FreeMemory(*Mem)
    Wend
  EndIf
EndProcedure

Procedure.i xfb_Allocate(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordSetID = RS_ID
      lResult = fb_allocate(@sv.ISC_STATUS,@fbRS()\DatabaseID,@fbRS()\QueryID)
      If lResult = 0
        ProcedureReturn #True
      Else
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False
      EndIf      
    EndIf
  Wend
  fb_LastErrorMessage = "xfbAllocate() - Invalid Recordset ID"
  ProcedureReturn #False
EndProcedure

Procedure.i xfb_Prepare(RS_ID)
  dbEncoding = xfb_rsEncoding(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID
      iQry = StringByteLength(fbRS()\Query,dbEncoding)
      *Qry = AllocateMemory(iQry)
      PokeS(*Qry,fbRS()\Query,iQry,dbEncoding)
      PokeW(fbRS()\BufferAddress,#SQLDA_VERSION1)
      lResult = fb_prepare(@sv.ISC_STATUS,@fbRS()\TransactionID,@fbRS()\QueryID,iQry,*Qry,#SQL_DIALECT_V6,fbRS()\BufferAddress)
      If lResult = 0
        ProcedureReturn #True
      Else
        FreeMemory(fbRS()\BufferAddress)
        fbRS()\BufferSize = 0
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False
      EndIf          
    EndIf
  Wend
  fb_LastErrorMessage = "xfb_Prepare() - Invalid Recordset ID"
  ProcedureReturn #False
EndProcedure

Procedure.i xfb_Describe(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID
      lResult = fb_describe(@sv.ISC_STATUS,@fbRS()\QueryID,#SQLDA_VERSION1,fbRS()\BufferAddress)
      If lResult = 0
        ProcedureReturn #True
      Else
        FreeMemory(fbRS()\BufferAddress)
        fbRS()\BufferSize = 0
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False   
      EndIf    
    EndIf
  Wend
  fb_LastErrorMessage = "xfb_Describe() - Invalid Recordset ID"
  ProcedureReturn #False
EndProcedure

Procedure.i xfb_Execute(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID
      lResult = fb_execute(@sv.ISC_STATUS,@fbRS()\TransactionID,@fbRS()\QueryID,#SQLDA_VERSION1,#Null)
      If lResult = 0
        ProcedureReturn #True
      Else
        FreeMemory(fbRS()\BufferAddress)
        fbRS()\BufferSize = 0
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False   
      EndIf     
    EndIf
  Wend
  fb_LastErrorMessage = "xfb_Execute() - Invalid Recordset ID"
  ProcedureReturn #False    
EndProcedure

;- this may not be an exhaustive list (need to check)
Procedure.i xfb_FieldBufferSize(FieldType,FieldSize)
  Select FieldType
  Case #SQL_TEXT, #SQL_TEXT + 1
    ProcedureReturn FieldSize
  Case #SQL_VARYING, #SQL_VARYING + 1
    ProcedureReturn FieldSize + 2
  Case #SQL_SHORT, #SQL_SHORT + 1
    ProcedureReturn 2
  Case #SQL_LONG, #SQL_LONG + 1, #SQL_FLOAT, #SQL_FLOAT + 1
    ProcedureReturn 4
  Case #SQL_INT64, #SQL_INT64 + 1, #SQL_DOUBLE, #SQL_DOUBLE + 1
    ProcedureReturn 8
  Case #SQL_D_FLOAT, #SQL_D_FLOAT + 1, #SQL_QUAD, #SQL_QUAD + 1
    ProcedureReturn 8
  Case #SQL_TYPE_TIME, #SQL_TYPE_TIME + 1, #SQL_TYPE_DATE, #SQL_TYPE_DATE + 1, #SQL_DATE, #SQL_DATE + 1
    ProcedureReturn 4
  Case #SQL_TIMESTAMP, #SQL_TIMESTAMP + 1
    ProcedureReturn 8
  Case #SQL_BLOB, #SQL_BLOB + 1
    ProcedureReturn 8
  Case #SQL_ARRAY, #SQL_ARRAY + 1
    ProcedureReturn 8
  Default
    ProcedureReturn FieldSize
  EndSelect
EndProcedure

Procedure.i xfb_GetMetaData(RS_ID, FieldCount)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID
      ResetList(fbFld())
      iPos = #fb_Size_XSQLDA
      For c = 1 To FieldCount
        AddElement(fbFld())
        fbFld()\RecordsetID = RS_ID
        fbFld()\Index = c
        fbFld()\Type = PeekW(fbRS()\BufferAddress + iPos + #fb_Offset_Type)
        fbFld()\Scale = PeekW(fbRS()\BufferAddress + iPos + #fb_Offset_Scale)        
        fbFld()\Size = PeekW(fbRS()\BufferAddress + iPos + #fb_Offset_Size)
        iNameLength = PeekW(fbRS()\BufferAddress + iPos + #fb_Offset_NameLength)
        fbFld()\Name = PeekS(fbRS()\BufferAddress + iPos + #fb_Offset_Name,iNameLength,fbEncoding_Meta)
        fbFld()\BufferSize = xfb_FieldBufferSize(fbFld()\Type,fbfld()\Size)
        If fbFld()\BufferSize = 0
          fb_LastErrorMessage = "Could not establish field size: " + fbFld()\Name
          ProcedureReturn #False
        EndIf
        fbFld()\BufferAddress = AllocateMemory(fbFld()\BufferSize)
        If fbFld()\BufferAddress = 0
          fb_LastErrorMessage = "Could not allocate field buffer"
          fbFld()\BufferSize = 0
          ProcedureReturn #False
        Else
          PokeL(fbRS()\BufferAddress + iPos + #fb_Offset_FieldBuffer,fbFld()\BufferAddress)
        EndIf
        fbFld()\IsNull = AllocateMemory(2)
        If fbFld()\IsNull = 0
          fb_LastErrorMessage = "Could not allocate field null buffer"
          ProcedureReturn #False
        Else
          PokeW(fbFld()\IsNull,0)
          PokeL(fbRS()\BufferAddress + iPos + #fb_Offset_NullBuffer,fbFld()\IsNull)
        EndIf        
        iPos = iPos + #fb_Size_XSQLVAR
      Next
      ProcedureReturn #True
    EndIf
  Wend
  fb_LastErrorMessage = "xfb_GetMetaData() - Invalid Recordset ID"
  ProcedureReturn #False   
EndProcedure

Procedure xfb_FreeFieldBuffers(RS_ID)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RS_ID
      If fbFld()\BufferAddress <> 0
        FreeMemory(fbFld()\BufferAddress)
        fbFld()\BufferSize = 0
      EndIf
      If fbFld()\IsNull <> 0 : FreeMemory(fbFld()\IsNull) : EndIf
      DeleteElement(fbFld())
    EndIf
  Wend
EndProcedure

;-------------------------------------------------------
;- These are the procedures you actually work with.
;- I've made them FAIRLY similar to standard PB database
;- commands so they should seem too daunting
;-------------------------------------------------------

Procedure.i fb_OpenDatabase(DatabaseAlias.s,Username.s,Password.s,dbEncoding=#PB_UTF8)
  lAlias.w = StringByteLength(DatabaseAlias,fbEncoding_Meta)
  *dbAlias = AllocateMemory(lAlias)
  PokeS(*dbAlias,DatabaseAlias,lAlias,fbEncoding_Meta)
  sParam.s = Chr(#isc_dpb_version1)
  lUN.w = StringByteLength(Username,fbEncoding_Meta)
  If lUN > 0:sParam = sParam + Chr(#isc_dpb_user_name) + Chr(lUN) + Username:EndIf
  lPWD.w = StringByteLength(Password,fbEncoding_Meta)
  If lPWD > 0:sParam = sParam + Chr(#isc_dpb_password) + Chr(lPWD) + Password:EndIf
  lUN = StringByteLength(sParam,fbEncoding_Meta)
  *dbParam = AllocateMemory(lUN)
  PokeS(*dbParam,sParam,lUN,fbEncoding_Meta)
  lHandle = #Null
  lresult = fb_attach(@sv.ISC_STATUS,lAlias,*dbAlias,@lHandle,lUN,*dbParam)
  FreeMemory(*dbAlias)
  FreeMemory(*dbParam)
  If lresult = 0
    AddElement(fbDB())
    fbDB()\DatabaseID = lHandle
    fbDB()\Encoding = dbEncoding
    ProcedureReturn lHandle
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure.i fb_CloseDatabase(dbHandle)
  lresult = fb_detach(@sv.ISC_STATUS,@dbHandle)
  If lresult = 0
    ResetList(fbDB())
    While NextElement(fbDB())
      If fbDB()\DatabaseID = dbHandle : DeleteElement(fbDB()) : Break : EndIf
    Wend
    ProcedureReturn lresult
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure.i fb_StartTransaction(dbHandle)
  *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)
  TransactionID = #Null
  lResult = fb_start(@sv.ISC_STATUS,@TransactionID,1,@dbHandle,4,*TPB)
  FreeMemory(*TPB)
  If lResult = 0
    ProcedureReturn TransactionID
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn -1   
  EndIf
EndProcedure

Procedure.i fb_CommitTransaction(TransactionID)
  lresult = fb_commit(@sv.ISC_STATUS,@TransactionID)
  If lresult = 0
    ProcedureReturn lresult
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure.i fb_RollbackTransaction(TransactionID)
  lresult = fb_rollback(@sv.ISC_STATUS,@TransactionID)
  If lresult = 0
    ProcedureReturn lresult
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure.i fb_SQLExecute(dbHandle,TransactionID,SQLString.s)
  dbEncoding = xfb_dbEncoding(dbHandle)
  lSQL = StringByteLength(SQLString,dbEncoding)
  *SQL = AllocateMemory(lSQL)
  PokeS(*SQL,SQLString,lSQL,dbEncoding)
  lResult = fb_execute_immediate(@sv.ISC_STATUS,@dbHandle,@TransactionID,lSQL,*SQL,#SQL_DIALECT_V6,#Null)
  FreeMemory(*SQL)
  If lResult = 0
    ProcedureReturn #True
  Else
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
EndProcedure

Procedure fb_CloseRecordset(RecordsetID)
  xfb_FreeFieldBuffers(RecordsetID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RecordsetID
      If fbRS()\BufferAddress <> 0
        FreeMemory(fbRS()\BufferAddress)
      EndIf
      DeleteElement(fbRS())
      Break
    EndIf
  Wend
EndProcedure

Procedure.i fb_SQLSelect(dbHandle,TransactionID,QryString.s)
  AddElement(fbRS())
  fbRS()\RecordsetID = CountList(fbRS())
  fbRS()\DatabaseID = dbHandle
  fbRS()\TransactionID = TransactionID
  fbRS()\Query = QryString
  fbRS()\BufferAddress = AllocateMemory(#fb_Size_XSQLDA + #fb_Size_XSQLVAR)
  fbRS()\BufferSize = #fb_Size_XSQLDA + #fb_Size_XSQLVAR
  
  If Not xfb_Allocate(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  If Not xfb_Prepare(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  If Not xfb_Describe(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  iFieldCount = PeekW(fbRS()\BufferAddress + #fb_Offset_FieldCount)
  If iFieldCount <= 0
    fb_LastErrorMessage = "Query returned no fields"
    ProcedureReturn -1
  EndIf
  FreeMemory(fbRS()\BufferAddress)
  iNewSize = (iFieldCount * #fb_Size_XSQLVAR) + #fb_Size_XSQLDA
  fbRS()\BufferAddress = AllocateMemory(iNewSize)
  If fbRS()\BufferAddress = 0
    fb_LastErrorMessage = "Couldn't allocate memory for recordset."
    ProcedureReturn -1
  EndIf
  fbRS()\BufferSize = iNewSize
  fbRS()\FieldCount = iFieldCount
  PokeW(fbRS()\BufferAddress,#SQLDA_VERSION1)
  PokeW(fbRS()\BufferAddress + #fb_Offset_XSQLVARS_Allocated,iFieldCount)
  If Not xfb_Describe(fbRS()\RecordsetID) : fb_CloseRecordset(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  If Not xfb_Execute(fbRS()\RecordsetID) : fb_CloseRecordset(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  If Not xfb_GetMetaData(fbRS()\RecordsetID,iFieldCount) : fb_CloseRecordset(fbRS()\RecordsetID) : ProcedureReturn -1 : EndIf
  ProcedureReturn fbRS()\RecordsetID
EndProcedure

Procedure.i fb_NextDatabaseRow(RS_ID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RS_ID
      PokeW(fbRS()\BufferAddress + #fb_Offset_FieldCount,fbRS()\FieldCount)
      lResult = fb_fetch(@sv.ISC_STATUS,@fbRS()\QueryID,#SQLDA_VERSION1,fbRS()\BufferAddress)
      If lResult = 0
        ProcedureReturn #True
      ElseIf lResult = 100
        ProcedureReturn #False
      Else
        FreeMemory(fbRS()\BufferAddress)
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False   
      EndIf
    EndIf
  Wend
  fb_LastErrorMessage = "fb_NextdatabaseRow() - Invalid Recordset ID"
  ProcedureReturn -1  
EndProcedure

Procedure.i fb_DatabaseColumns(RecordsetID)
  ResetList(fbRS())
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RecordsetID
      ProcedureReturn fbRS()\FieldCount
    EndIf
  Wend
  fb_LastErrorMessage = "fb_DatabaseColumns() - Invalid Recordset ID"
  ProcedureReturn -1  
EndProcedure

Procedure.s fb_DatabaseColumnName(RecordsetID,ColumnIndex)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex
      ProcedureReturn fbFld()\Name
    EndIf
  Wend
  fb_LastErrorMessage = "fb_DatabaseColumnName() - Invalid Recordset ID"
  ProcedureReturn ""   
EndProcedure

Procedure.i fb_DatabaseColumnType(RecordsetID,ColumnIndex)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex
      ProcedureReturn fbFld()\Type
    EndIf
  Wend
  fb_LastErrorMessage = "fbDatabaseColumnType() - Invalid Recordset ID"
  ProcedureReturn -1   
EndProcedure

Procedure.i fb_DatabaseColumnSize(RecordsetID,ColumnIndex)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex
      ProcedureReturn fbFld()\Size
    EndIf
  Wend
  fb_LastErrorMessage = "fb_DatabaseColumnSize() - Invalid Recordset ID"
  ProcedureReturn -1   
EndProcedure

Procedure.i fb_DatabaseColumnScale(RecordsetID,ColumnIndex)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex
      ProcedureReturn fbFld()\Scale
    EndIf
  Wend
  fb_LastErrorMessage = "fb_DatabaseColumnScale() - Invalid Recordset ID"
  ProcedureReturn -1   
EndProcedure

Procedure.i fb_DatabaseColumnIsNull(RecordsetID,ColumnIndex)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex
      wFld.w = PeekW(fbFld()\IsNull)
      If wFld = -1
        ProcedureReturn #True
      Else
        ProcedureReturn #False
      EndIf
    EndIf
  Wend
  ProcedureReturn #False
EndProcedure

;- someone please check and confirm these string conversions for me
;- also need to figure how to turn dates and times into something intelligible
Procedure.s fb_GetDatabaseString(RecordsetID,ColumnIndex)
  dbEncoding = xfb_rsEncoding(RecordsetID)
  ResetList(fbFld())
  While NextElement(fbFld())
    If fbFld()\RecordsetID = RecordsetID And fbFld()\Index = ColumnIndex      
      Select fbFld()\Type
      Case #SQL_VARYING, #SQL_VARYING + 1
        wSize.w = PeekW(fbFld()\BufferAddress)
        sText.s = PeekS(fbFld()\BufferAddress + 2,wSize,dbEncoding)
      Case #SQL_TEXT, #SQL_TEXT + 1
        sText.s = PeekS(fbFld()\BufferAddress,fbFld()\BufferSize,dbEncoding)
      Case #SQL_SHORT, #SQL_SHORT + 1
        wSize.w = PeekW(fbFld()\BufferAddress)
        sText.s = Str(wSize)
      Case #SQL_LONG, #SQL_LONG + 1
        iSize.i = PeekL(fbFld()\BufferAddress)
        sText.s = Str(iSize)
      Case #SQL_FLOAT, #SQL_FLOAT + 1
        fSize.f = PeekF(fbFld()\BufferAddress)
        sText.s = StrF(fSize)
      Case #SQL_INT64, #SQL_INT64 + 1, #SQL_QUAD, #SQL_QUAD + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = Str(qSize)
      Case #SQL_D_FLOAT, #SQL_D_FLOAT + 1, #SQL_DOUBLE, #SQL_DOUBLE + 1
        dSize.d = PeekD(fbFld()\BufferAddress)
        sText.s = StrD(dSize)
      Case #SQL_TYPE_TIME, #SQL_TYPE_TIME + 1, #SQL_TYPE_DATE, #SQL_TYPE_DATE + 1, #SQL_DATE, #SQL_DATE + 1
        iSize.i = PeekL(fbFld()\BufferAddress)
        sText.s = Str(iSize)
      Case #SQL_TIMESTAMP, #SQL_TIMESTAMP + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = Str(qSize)
      ;- haven't done blobs or arrays yet, this will just return the ID     
      Case #SQL_BLOB, #SQL_BLOB + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = Str(qSize)
      Case #SQL_ARRAY, #SQL_ARRAY + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = Str(qSize)             
      Default
        sText.s = "I haven't coded this yet!"
      EndSelect
      ProcedureReturn sText
    EndIf
  Wend
  ProcedureReturn ""
EndProcedure


;- start the test
;Employees is an alias I've set up for the Employees example database that installs with Firebird

db = fb_OpenDatabase("localhost:Employees","sysdba","masterkey")
If db = -1
  MessageRequester("Error",fb_LastErrormessage,0)
Else
  lTransID = fb_StartTransaction(db)
  If lTransID = -1
    MessageRequester("Error",fb_LastErrormessage,0)
  Else
      iRecordSet = fb_SQLSelect(db,lTransID,"SELECT * FROM EMPLOYEE ORDER BY FIRST_NAME, LAST_NAME;")
      If iRecordSet = -1
        MessageRequester("Error",fb_LastErrormessage,0)
      Else
        iColCount = fb_DatabaseColumns(iRecordset)
        While fb_NextDatabaseRow(iRecordSet)
          txt.s = ""
          For c = 1 To iColCount
            If fb_DatabaseColumnIsNull(iRecordset,c)
              txt.s = txt.s + "#Null"
            Else
              txt.s = txt.s + fb_GetDatabaseString(iRecordset,c)
            EndIf
            If c < iColCount : txt.s = txt.s + ", " : EndIf
          Next
          Debug txt.s
          iRecordCount = iRecordCount + 1
        Wend
        MessageRequester("Cool!","Record count:" + Str(iRecordCount),0)
        fb_CloseRecordset(iRecordset)
      EndIf      
      fb_CommitTransaction(lTransID)
    EndIf
    fb_CloseDatabase(dbHandle)
  EndIf

CloseLibrary(#FB_Client)

The only test this code has had is the little routine right at the end so there may be the odd buglet or two in there.

If you find something let me know.

Weave

[thanos]

The only test this code has had is the little routine right at the end so there may be the odd buglet or two in there.

If you find something let me know.

Weave

Hello and thanks a lot for the code!
It is working perfectly.
But it does not display the unicode characters from the database nor accept them to query the database.
I have a database with the WIN1253 as the default character set.
Best regards.

Thanos

[the.weavster]

I've edited the code above to allow for different database encodings.

There is now an optional fourth parameter for fb_OpenDatabase which should be one of PureBasics text encoding constants, the default encoding is #PB_UTF8.

This change is COMPLETELY untested, please let me know if it works ok.

[the.weavster]

I just remembered I should've edited the fb_CloseDatabase() procedure to remove the database from the new fbDB() linked list.

I'll correct it later, there's still enough here for you to try.

[thanos]

I just remembered I should've edited the fb_CloseDatabase() procedure to remove the database from the new fbDB() linked list.

I'll correct it later, there's still enough here for you to try.

Still not displaying the characters correctly.
I run a query and i took the following results:

instead of the right results:

Sorry for the "punishment"
Regards.

Thanos

[thanos]

I just remembered I should've edited the fb_CloseDatabase() procedure to remove the database from the new fbDB() linked list.

I'll correct it later, there's still enough here for you to try.

It is still not displaying the characters correctly.
I run a query and i took the following results:

instead of the right results:

I am sorry for the "punishment"
Regards.

Thanos

[the.weavster]

I have a database with the WIN1253 as the default character set.

From a quick google it seems WIN1253 is not a unicode character set, it's a Windows only, single-byte character set.

Also it looks from the PB help file Ascii, UTF8 and UTF16 are the options in PB. I don't know the answer I'm afraid, being an English speaker even ascii is really good enough for me.

Maybe you'll be able to find a utility that will convert your database to UTF8, which afaik is the only unicode character set Firebird supports.

[thanos]

I have a database with the WIN1253 as the default character set.

From a quick google it seems WIN1253 is not a unicode character set, it's a Windows only, single-byte character set.

Also it looks from the PB help file Ascii, UTF8 and UTF16 are the options in PB. I don't know the answer I'm afraid, being an English speaker even ascii is really good enough for me.

Maybe you'll be able to find a utility that will convert your database to UTF8, which afaik is the only unicode character set Firebird supports.

I am sorry!
It was my fault.
Of course the WIN1253 is an ansi character set.
I created a new database with UTF8 character set and everything gone perfect both on PureBasic and my VB application.
I will try to find a utility to convert the database
Thank you my friend.
Regards.

Thanos

[the.weavster]

I just remembered I should've edited the fb_CloseDatabase() procedure to remove the database from the new fbDB() linked list.

Now sorted and updated.

Thank you my friend.

No problem, I hope it proves useful.

[thanos]

No problem, I hope it proves useful.

Thank you again.
It is already useful.
I can handle some database tasks with small sized utilities written in PureBasic.
Keep up the good work!
Regards.

Thanos

[thanos]

What is the installation path of the server? The database files have to be on a hard disk that is physically attached to your server machine, shares or mapped drives will not work.

Hello the.weavster!
Long time to post in this thread
I faced to the following problem:
I am running the Firebird server to my network server (its name is PEGASUS).
When i am trying to connect into the Evo_Demo.fdb, which is physically atached to this machine on the logical partition O: in the path \Data\Evolution O:\Data\Evolution i received errors in connection.
I also received errors when i am trying to connect to this database via a Visual Basic application.
I have share the \\PEGASUS\Data\Evolution and i have map it as V:\Evolution.
When i run the exe file from a remote desktop everything is fine.
But when i run the exe file from V:\Evolution i can not connect to the database.
I was try to connect via the Firebird's odbc:

Code: Select all

DRIVER={Firebird/InterBase(r) driver};SERVER=PEGASUS;UID=SYSDBA;PWD=masterkey;DATABASE=PEGASUS:V:\Evolution\Evo_Demo.fdb;Mode=Read|Write;

I also tried to give aliases such as:
Evo_Demo = \\Pegasus\data_net\Evolution\Evo_Demo.fdb
and
Evo_Demo = V:\Evolution\Evo_Demo.fdb
Do you have any idea?
I have installed the firebird server and the firebird odbc driver into my local pc.
I also tried to connect to the database with FlameRobin tool.
I gave both the database paths:

In both cases i received the following error:

Code: Select all

SQL message: -904
Unsuccessful execution caused by an unavailable resource.

Engine code: 335544375
Engine message: Unavailable database

Thanks in advance.
Regards

Thanos

[the.weavster]

I hope I'm understanding you correctly, when you connect from a remote computer it works OK but when you connect locally it wont work, is that correct?

If so I would think the problem is the protocol being used. By default Firebird uses XNET for local connections unless you specify the localhost loopback which makes it use TCP.

Try changing your connection string to:

Code: Select all

DRIVER={Firebird/InterBase(r) driver};UID=SYSDBA;PWD=masterkey;DBNAME=localhost:Evo_Demo;

I still suspect the version of fbclient.dll you are using doesn't match the version of your Firebird server.