Firebird Database Server client module

Share your advanced PureBasic knowledge/code with the community.
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 »

Thank you :D
Greetings and thanks!

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

Re: Firebird Database Server client module

Post by the.weavster »

I've just created an alternative API which I personally prefer to my original module:

The declares [ fbdb-declares.pb ]

Code: Select all

Declare.i _fb_function(FunctionName.s)
Declare.i _fb_buffer_size(nFields)
Declare _fb_create_buffers(*sqlda_out, nFields.w)
Declare.i _fb_describe(*sv, stmt, *sqlda_out, nFields.w)
Declare _fb_describe_bind(*sv, stmt, *sqlda_in, nFields.w)
Declare.i _fb_execute(*sv, txh, stmt, *sqlda_in=#Null)
Declare.s _fb_extract_date(nDate.i)
Declare.s _fb_extract_time(nTime.i)
Declare.i _fb_field_string(*fld.firebird_field)
Declare _fb_free_buffers(*bfr)
Declare.i _fb_position_pointer(nFields)
Declare _fb_new_sqlda(*buffer, nFields.w, isparams=#False)
Declare.w _fb_prepare(*sv, txh, stmt, sql.s)
Declare.i _fb_sql_execute(*cr.firebird_cursor, qry.s)
Declare.i _fb_sql_executep(*cr.firebird_cursor)
Declare.i _fb_sql_select(*cr.firebird_cursor, qry.s)
Declare.i _fb_sql_selectp(*cr.firebird_cursor)
Declare _fb_get_fields(*rs.firebird_recordset)
Declare.i fbdb_connect(*fdb.firebird_database, db.s, uid.s, pwd.s, role.s="")
Declare fbdb_close(*db.firebird_database)
Declare.i fbdb_cursor(*db)
Declare.i fbdb_begin(*db.firebird_database)
Declare.i fbdb_commit(*db.firebird_database)
Declare.i fbdb_rollback(*db.firebird_database)
Declare.s fbdb_error_message(*db.firebird_database)
Declare fbdb_free(*db.firebird_database)
Declare.i FirebirdDatabase()
Declare fbcr_bind_double(*cr.firebird_cursor, idx, itm.d)
Declare fbcr_bind_float(*cr.firebird_cursor, idx, itm.f)
Declare fbcr_bind_integer(*cr.firebird_cursor, idx, itm.i)
Declare fbcr_bind_null(*cr.firebird_cursor, idx)
Declare fbcr_bind_string(*cr.firebird_cursor, idx, itm.s)
Declare.i fbcr_prepare(*cr.firebird_cursor, sql.s)
Declare.i fbcr_sql_execute(*cr.firebird_cursor, sql.s="")
Declare.i fbcr_sql_select(*cr.firebird_cursor, sql.s="")
Declare.i fbcr_free(*cr.firebird_cursor)
Declare.i FirebirdCursor(*db.firebird_database)
Declare fbrs_move_next(*rs.firebird_recordset)
Declare.i fbrs_field_count(*rs.firebird_recordset)
Declare.i fbrs_field_by_index(*rs.firebird_recordset, idx)
Declare.i fbrs_field_by_name(*rs.firebird_recordset, fname.s)
Declare.s fbrs_field_name(*rs.firebird_recordset, idx)
Declare.i fbrs_field_type(*rs.firebird_recordset, idx)
Declare.i fbrs_field_subtype(*rs.firebird_recordset, idx)
Declare.i fbrs_field_size(*rs.firebird_recordset, idx)
Declare.i fbrs_field_scale(*rs.firebird_recordset, idx)
Declare.i fbrs_field_length(*rs.firebird_recordset, idx)
Declare.i fbrs_field_pbtype(*rs.firebird_recordset, idx)
Declare.i fbrs_field_isnull(*rs.firebird_recordset, idx)
Declare.s fbrs_field_date(*rs.firebird_recordset, idx)
Declare.d fbrs_field_double(*rs.firebird_recordset, idx)
Declare.f fbrs_field_float(*rs.firebird_recordset, idx)
Declare.i fbrs_field_integer(*rs.firebird_recordset, idx)
Declare.q fbrs_field_quad(*rs.firebird_recordset, idx)
Declare.s fbrs_field_string(*rs.firebird_recordset, idx)
Declare.s fbrs_field_time(*rs.firebird_recordset, idx)
Declare.s fbrs_field_timestamp(*rs.firebird_recordset, idx)
Declare fbrs_free(*rs.firebird_recordset)
Declare.i FirebirdRecordSet(*cr.firebird_cursor)
The wrapper [ fbdb.pb ]

Code: Select all

;-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
;-blob constants
#isc_info_end               = 1
#isc_segment                = 335544366
#isc_segstr_eof             = 335544367
#isc_info_blob_num_segments = 4
#isc_info_blob_max_segment  = 5
#isc_info_blob_total_length = 6
#isc_info_blob_type         = 7

#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 blobInfo
  BlobHandle.i
  BlobID.q
  DatabaseID.i
  TransactionID.i
  WriteMode.i
  mRefCount.i
  Sizes.q
  Largest.l
  Segments.l
  Blobtype.i
  BytesRW.q
  BytesToRW.q
EndStructure

;this is actually not being used, it's here for info
Structure tm
  tm_sec.i     ; seconds after the minute - [0, 60]
  tm_min.i     ; minutes after the hour - [0, 59]
  tm_hour.i    ; hours since midnight - [0, 23]
  tm_mday.i    ; day of the month - [1, 31]
  tm_mon.i     ; months since January - [0, 11]
  tm_year.i    ; years since 1900
  tm_wday.i    ; days since Sunday - [0, 6]
  tm_yday.i    ; days since January 1 - [0, 365]
  tm_isdst.i   ; Daylight Saving Time flag
EndStructure

Global fbLibrary$
CompilerSelect #PB_Compiler_OS
  CompilerCase #PB_OS_Windows
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      fbLibrary$ = "fbclient32.dll"
    CompilerElse
      fbLibrary$ = "fbclient.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

;- library prototypes
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)
  Prototype.i isc_open_blob2(*StatusVector, *dbHandle, *TransactionHandle, *BlobHandle, *ISC_QUAD, ISC_USHORT.w, *Sstring)
  Prototype.i isc_cancel_blob(*StatusVector, *BlobHandle)
  Prototype.i isc_create_blob2(*StatusVector, *dbHandle, *TransactionHandle, *BlobHandle, *ISC_QUAD, short.w, *Sstring)
  Prototype.i isc_close_blob(*StatusVector, *BlobHandle)
  Prototype.i isc_blob_info(*StatusVector, *BlobHandle, sshort.w, *Sstring, short.w, *Sstring1)
  Prototype.i isc_get_segment(*StatusVector, *BlobHandle, *unsignedshort, ushort.w, *Sstring)
  Prototype.i isc_put_segment(*StatusVector, *BlobHandle, ushort.w, *Sstring)
  Prototype.l isc_vax_integer(*Sstring, short.w)
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)
  PrototypeC.i isc_open_blob2(*StatusVector, *dbHandle, *TransactionHandle, *BlobHandle, *ISC_QUAD, ISC_USHORT.w, *Sstring)
  PrototypeC.i isc_cancel_blob(*StatusVector, *BlobHandle)
  PrototypeC.i isc_create_blob2(*StatusVector, *dbHandle, *TransactionHandle, *BlobHandle, *ISC_QUAD, short.w, *Sstring)
  PrototypeC.i isc_close_blob(*StatusVector, *BlobHandle)
  PrototypeC.i isc_blob_info(*StatusVector, *BlobHandle, sshort.w, *Sstring, short.w, *Sstring1)
  PrototypeC.i isc_get_segment(*StatusVector, *BlobHandle, *unsignedshort, ushort.w, *Sstring)
  PrototypeC.i isc_put_segment(*StatusVector, *BlobHandle, ushort.w, *Sstring)
  PrototypeC.l isc_vax_integer(*Sstring, short.w)
CompilerEndIf

;this is a C pointer on any platform
PrototypeC.i isc_start_transaction(*StatusVector, *TransactionHandle, Count.w, *dbHandle, TPBLength.w, *TPB)

;- local prototypes
Prototype.i fbdb_connect(*db, db.s, uid.s, pwd.s, role.s="")
Prototype fbdb_close(*db)
Prototype.i fbdb_cursor(*db)
Prototype.i fbdb_begin(*db)
Prototype.i fbdb_commit(*db)
Prototype.i fbdb_rollback(*db)
Prototype.s fbdb_error_message(*db)
Prototype fbdb_free(*db)

Prototype.i fbcr_bind_double(*cr, idx, itm.d)
Prototype.i fbcr_bind_float(*cr, idx, itm.f)
Prototype.i fbcr_bind_integer(*cr, idx, itm.i)
Prototype.i fbcr_bind_null(*cr, idx)
Prototype.i fbcr_bind_string(*cr, idx, itm.s)
Prototype.i fbcr_prepare(*cr, sql.s)
Prototype.i fbcr_sql_execute(*cr, sql.s="")
Prototype.i fbcr_sql_select(*cr, sql.s="")
Prototype fbcr_free(*cr)

Prototype fbrs_move_next(*rs)
Prototype.i fbrs_field_count(*rs)
Prototype.i fbrs_field_by_index(*rs, idx)
Prototype.i fbrs_field_by_name(*rs, fname.s)
Prototype.s fbrs_field_name(*rs, idx)
Prototype.i fbrs_field_type(*rs, idx)
Prototype.i fbrs_field_subtype(*rs, idx)
Prototype.i fbrs_field_size(*rs, idx)
Prototype.i fbrs_field_scale(*rs, idx)
Prototype.i fbrs_field_length(*rs, idx)
Prototype.i fbrs_field_pbtype(*rs, idx)
Prototype.i fbrs_field_isnull(*rs, idx)
Prototype.s fbrs_field_date(*rs, idx)
Prototype.d fbrs_field_double(*rs, idx)
Prototype.f fbrs_field_float(*rs, idx)
Prototype.i fbrs_field_integer(*rs, idx)
Prototype.q fbrs_field_quad(*rs, idx)
Prototype.s fbrs_field_string(*rs, idx)
Prototype.s fbrs_field_time(*rs, idx)
Prototype.s fbrs_field_timestamp(*rs, idx)
Prototype fbrs_free(*rs)

Structure firebird_database
  dbh.i
  txh.i
  error.s
  *sv
  *Connect.fbdb_connect
  *Close.fbdb_close
  *Cursor.fbdb_cursor
  *Begin.fbdb_begin
  *Commit.fbdb_commit
  *Rollback.fbdb_rollback
  *LastError.fbdb_error_message
  *Free.fbdb_free
EndStructure

Structure firebird_cursor
  stmt.i
  bind_count.i
  *bfr_in
  *bfr_out  
  *dbh.firebird_database
  *BindDouble.fbcr_bind_double
  *BindFloat.fbcr_bind_float
  *BindInteger.fbcr_bind_integer
  *BindNull.fbcr_bind_null
  *BindString.fbcr_bind_string
  *Prepare.fbcr_prepare
  *SQLExecute.fbcr_sql_execute
  *SQLSelect.fbcr_sql_select
  *Free.fbcr_free
EndStructure

Structure firebird_field
  name.s
  type.w
  subtype.w
  size.w
  scale.w
  isnull.w
  length.w
  buffer.i
  pbtype.i
  stringval.s
EndStructure

Structure firebird_recordset
  current_record.i
  *cursor.firebird_cursor
  *Fetch.fbrs_move_next
  *FieldCount.fbrs_field_count
  *FieldByIndex.fbrs_field_by_index
  *FieldIndexByName.fbrs_field_by_name
  *FieldName.fbrs_field_name
  *FieldType.fbrs_field_type
  *FieldSubtype.fbrs_field_subtype
  *FieldSize.fbrs_field_size
  *FieldScale.fbrs_field_scale
  *FieldLength.fbrs_field_length
  *FieldPBType.fbrs_field_pbtype
  *FieldIsNull.fbrs_field_isnull
  *FieldDate.fbrs_field_date
  *FieldDouble.fbrs_field_double
  *FieldFloat.fbrs_field_float
  *FieldInteger.fbrs_field_integer
  *FieldQuad.fbrs_field_quad
  *FieldString.fbrs_field_string
  *FieldTime.fbrs_field_time
  *FieldTimestamp.fbrs_field_timestamp
  *Free.fbrs_free
  List fields.firebird_field()
EndStructure

XIncludeFile "fbdb-declares.pb"
Procedure.i _fb_function(FunctionName.s)
  Define.i nRes = GetFunction(#FB_Client, FunctionName)
  If nRes
    ProcedureReturn nRes
  Else
    MessageRequester("Error", "Function not found: " + FunctionName, 0)
    End
  EndIf
EndProcedure

Global fb_attach.isc_attach_database                   = _fb_function("isc_attach_database")
Global fb_detach.isc_detach_database                   = _fb_function("isc_detach_database")
Global fb_start.isc_start_transaction                  = _fb_function("isc_start_transaction")
Global fb_rollback.isc_rollback_transaction            = _fb_function("isc_rollback_transaction")
Global fb_commit.isc_commit_transaction                = _fb_function("isc_commit_transaction")
Global fb_allocate.isc_dsql_alloc_statement2           = _fb_function("isc_dsql_alloc_statement2")
Global fb_prepare.isc_dsql_prepare                     = _fb_function("isc_dsql_prepare") 
Global fb_describe.isc_dsql_describe                   = _fb_function("isc_dsql_describe")
Global fb_describe_bind.isc_dsql_describe_bind         = _fb_function("isc_dsql_describe_bind")
Global fb_error.fb_interpret                           = _fb_function("fb_interpret")
Global fb_sqlcode.isc_sqlcode                          = _fb_function("isc_sqlcode")
Global fb_sql_error.isc_sql_interpret                  = _fb_function("isc_sql_interprete")
Global fb_fetch.isc_dsql_fetch                         = _fb_function("isc_dsql_fetch")
Global fb_free.isc_dsql_free_statement                 = _fb_function("isc_dsql_free_statement")
Global fb_execute_immediate.isc_dsql_execute_immediate = _fb_function("isc_dsql_execute_immediate")
Global fb_execute.isc_dsql_execute                     = _fb_function("isc_dsql_execute")
Global fb_execute2.isc_dsql_execute2                   = _fb_function("isc_dsql_execute2")
Global fb_openblob.isc_open_blob2                      = _fb_function("isc_open_blob2")
Global fb_cancelblob.isc_cancel_blob                   = _fb_function("isc_cancel_blob")
Global fb_createblob.isc_create_blob2                  = _fb_function("isc_create_blob2")
Global fb_closeblob.isc_close_blob                     = _fb_function("isc_close_blob")
Global fb_infoblob.isc_blob_info                       = _fb_function("isc_blob_info")
Global fb_getsegment.isc_get_segment                   = _fb_function("isc_get_segment")
Global fb_putsegment.isc_put_segment                   = _fb_function("isc_put_segment")
Global fb_vaxinteger.isc_vax_integer                   = _fb_function("isc_vax_integer")

Procedure.i _fb_buffer_size(nFields)
  ProcedureReturn (nFields * SizeOf(XSQLVAR)) + SizeOf(XSQLDA) + 20
EndProcedure  

Procedure _fb_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 _fb_describe(*sv, stmt, *sqlda_out, nFields.w)
  _fb_new_sqlda(*sqlda_out, nFields)
  nResult = fb_describe(*sv, @stmt, 1, *sqlda_out)
  If nResult = 0
    _fb_create_buffers(*sqlda_out, nFields)
    nCheck = PeekW(*sqlda_out+OffsetOf(XSQLDA\sqld))
    ProcedureReturn nCheck
  Else
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure _fb_describe_bind(*sv, stmt, *sqlda_in, nFields.w)
  _fb_new_sqlda(*sqlda_in, nFields)
  nResult = fb_describe_bind(*sv, @stmt, 1, *sqlda_in)
  If nResult = 0
    _fb_create_buffers(*sqlda_in, nFields)
    nCheck = PeekW(*sqlda_in+OffsetOf(XSQLDA\sqld))
    ProcedureReturn nCheck
  Else
    ProcedureReturn -1
  EndIf    
EndProcedure

Procedure.i _fb_execute(*sv, txh, stmt, *sqlda_in=#Null)
  ProcedureReturn fb_execute(*sv, @txh, @stmt, #SQLDA_VERSION1, *sqlda_in)
EndProcedure

Procedure.s _fb_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 _fb_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 _fb_field_string(*fld.firebird_field)
  Select *fld\type
    Case #FB_SQL_TEXT
      *fld\stringval = PeekS(*fld\buffer, *fld\size, #PB_UTF8)
      *fld\pbtype = #PB_Database_String
    Case #FB_SQL_TEXT + 1
      *fld\stringval = PeekS(*fld\buffer, *fld\size, #PB_UTF8)
      *fld\pbtype = #PB_Database_String
    Case #FB_SQL_VARYING
      *fld\stringval = PeekS(*fld\buffer, -1, #PB_UTF8)
      *fld\pbtype = #PB_Database_String
    Case #FB_SQL_VARYING + 1
      *fld\stringval = PeekS(*fld\buffer, -1, #PB_UTF8)
      *fld\pbtype = #PB_Database_String
    Case #FB_SQL_FLOAT, #FB_SQL_FLOAT + 1
      *fld\stringval = StrF(PeekF(*fld\buffer))
      *fld\pbtype = #PB_Database_Float
    Case #FB_SQL_D_FLOAT, #FB_SQL_D_FLOAT + 1
      *fld\stringval = StrF(PeekF(*fld\buffer))
      *fld\pbtype = #PB_Database_Float
    Case #FB_SQL_DOUBLE, #FB_SQL_DOUBLE + 1
      *fld\stringval = StrD(PeekD(*fld\buffer))
      *fld\pbtype = #PB_Database_Double
    Case #FB_SQL_INT64, #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_SQL_SHORT, #FB_SQL_SHORT + 1
      *fld\stringval = Str(PeekC(*fld\buffer))
      *fld\pbtype = #PB_Database_Long
    Case #FB_SQL_BLOB, #FB_SQL_BLOB + 1
      Define.i blobid = PeekI(*fld\buffer), blobsize = PeekI(*fld\size)
      If *fld\subtype = 1
        
      Else
        
      EndIf
    Case #FB_SQL_TIMESTAMP, #FB_SQL_TIMESTAMP + 1
      *fld\stringval = _fb_extract_date(PeekL(*fld\buffer))
      *fld\stringval + " "
      *fld\stringval + _fb_extract_time(PeekL(*fld\buffer+4))
      *fld\pbtype = #Null
    Case #FB_SQL_TYPE_DATE, #FB_SQL_TYPE_DATE + 1
      *fld\stringval = _fb_extract_date(PeekL(*fld\buffer))
      *fld\pbtype = #Null
    Case #FB_SQL_TYPE_TIME, #FB_SQL_TYPE_TIME + 1
      *fld\stringval = _fb_extract_time(PeekL(*fld\buffer))
      *fld\pbtype = #Null
    Default
      *fld\stringval = "Unsupported Type: " + Str(*fld\type)
      *fld\pbtype = #Null
  EndSelect    
  ProcedureReturn *fld
EndProcedure

Procedure _fb_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 _fb_position_pointer(nFields)
  nPos = (nFields-1) * SizeOf(XSQLVAR)
  nPos = nPos + SizeOf(XSQLDA)
  ProcedureReturn nPos
EndProcedure

Procedure _fb_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 _fb_prepare(*sv, txh, stmt, sql.s)
  *sqlda_out = AllocateMemory(_fb_buffer_size(1))
  _fb_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 _fb_sql_execute(*cr.firebird_cursor, qry.s)
  Define.i nSQL = StringByteLength(qry, #PB_UTF8) + 4
  *sql = AllocateMemory(nSQL)
  PokeS(*sql, qry, nSQL, #PB_UTF8)
  Define.i Res = fb_execute_immediate(*cr\dbh\sv, @*cr\dbh\dbh, @*cr\dbh\txh, nSQL, *sql, #FB_SQL_DIALECT_V6, #Null)
  FreeMemory(*sql)
  If Res = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf 
EndProcedure

Procedure.i _fb_sql_executep(*cr.firebird_cursor)
  Define.i Res = _fb_execute(*cr\dbh\sv, *cr\dbh\txh, *cr\stmt, *cr\bfr_in)
  If Res = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf 
EndProcedure

Procedure.i _fb_sql_select(*cr.firebird_cursor, qry.s)
  Define.i nFields = _fb_prepare(*cr\dbh\sv, *cr\dbh\txh, *cr\stmt, qry)
  If nFields = -1 Or nFields = 0 : ProcedureReturn #False : EndIf
  *cr\bfr_out = AllocateMemory(_fb_buffer_size(nFields))
  Define.i Res = _fb_describe(*cr\dbh\sv, *cr\stmt, *cr\bfr_out, nFields)
  If Res = -1
    FreeMemory(*cr\bfr_out)
    ProcedureReturn #Null
  EndIf
  If _fb_execute(*cr\dbh\sv, *cr\dbh\txh, *cr\stmt) = 0
    *rs.firebird_recordset = FirebirdRecordSet(*cr)
    ProcedureReturn *rs
  Else
    FreeMemory(*cr\bfr_out)
    ProcedureReturn #Null
  EndIf
EndProcedure

Procedure.i _fb_sql_selectp(*cr.firebird_cursor)
  *cr\bfr_out = AllocateMemory(_fb_buffer_size(1))
  Define.i Res = _fb_describe(*cr\dbh\sv, *cr\stmt, *cr\bfr_out, 1)
  If Res = -1
    FreeMemory(*cr\bfr_out)
    ProcedureReturn #Null
  EndIf
  If Res > 1
    FreeMemory(*cr\bfr_out)
    *cr\bfr_out = AllocateMemory(_fb_buffer_size(Res))
    Res = _fb_describe(*cr\dbh\sv, *cr\stmt, *cr\bfr_out, Res)
    If Res = -1
      FreeMemory(*cr\bfr_out)
      ProcedureReturn #Null
    EndIf
  EndIf
  Res = _fb_execute(*cr\dbh\sv, *cr\dbh\txh, *cr\stmt, *cr\bfr_in)
  If Res = 0
    *rs.firebird_recordset = FirebirdRecordSet(*cr)
    ProcedureReturn *rs
  Else
    ProcedureReturn #Null
  EndIf  
EndProcedure

Procedure _fb_get_fields(*rs.firebird_recordset)
  Define.i nFieldCount = PeekW(*rs\cursor\bfr_out+OffsetOf(XSQLDA\sqld))
  Define.i idx = 1, nPos, nNameLength, nIsNullP
  Define.w nIsNull
  Define.s sFieldName
  ClearList(*rs\fields())
  While idx <= nFieldCount
    nPos = *rs\cursor\bfr_out + _fb_position_pointer(idx)
    nNameLength  = PeekW(nPos+OffsetOf(XSQLVAR\sqlname_length))
    sFieldName   = PeekS(nPos+OffsetOf(XSQLVAR\sqlname), nNameLength, #PB_UTF8)
    nIsNullP     = PeekI(nPos+OffsetOf(XSQLVAR\sqlind))
    nIsNull      = PeekW(nIsNullP)
    AddElement(*rs\fields())
    *rs\fields()\name     = sFieldName
    *rs\fields()\size     = PeekW(nPos+OffsetOf(XSQLVAR\sqllen))
    *rs\fields()\scale    = PeekW(nPos+OffsetOf(XSQLVAR\sqlscale))
    *rs\fields()\type     = PeekW(nPos+OffsetOf(XSQLVAR\sqltype))
    *rs\fields()\subtype  = PeekW(nPos+OffsetOf(XSQLVAR\sqlsubtype))
    *rs\fields()\buffer   = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
    If *rs\fields()\type  = #FB_SQL_VARYING Or *rs\fields()\type = #FB_SQL_VARYING + 1
      *rs\fields()\length = PeekW(*rs\fields()\buffer)
      *rs\fields()\buffer = *rs\fields()\buffer + 2
    EndIf
    If nIsNull = 0
      *rs\fields()\isnull = #False
    Else
      *rs\fields()\isnull = #True
    EndIf
    _fb_field_string(*rs\fields())    
    idx + 1
  Wend
EndProcedure

;- API Section
;- database
Procedure.i fbdb_connect(*fdb.firebird_database, db.s, uid.s, pwd.s, role.s="")
  Define.w nAlias = StringByteLength(db, #PB_UTF8)
  Define *dbAlias = AllocateMemory(nAlias)
  PokeS(*dbAlias, db, nAlias, #PB_UTF8|#PB_String_NoZero)
  Define.s Param$ = Chr(#isc_dpb_version1)
  Define.w nUN = StringByteLength(uid, #PB_UTF8)
  If nUN > 0 : Param$ + Chr(#isc_dpb_user_name) + Chr(nUN) + uid  : EndIf
  Define.w nPWD = StringByteLength(pwd, #PB_UTF8)
  If nPWD > 0 : Param$ + Chr(#isc_dpb_password) + Chr(nPWD) + pwd : EndIf
  If role <> ""
    Define.w nRL = 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)
  Define *dbParam = UTF8(Param$)
  Define nResult = fb_attach(*fdb\sv, nAlias, *dbAlias, @*fdb\dbh, nUN, *dbParam)
  FreeMemory(*dbAlias)
  FreeMemory(*dbParam)
  If nResult = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

Procedure fbdb_close(*db.firebird_database)
  nResult.i = fb_detach(*db\sv, @*db\dbh)
  *db\dbh = 0
  *db\Free(*db)
  If nResult = 0
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

Procedure.i fbdb_cursor(*db)
  ProcedureReturn FirebirdCursor(*db)
EndProcedure

Procedure.i fbdb_begin(*db.firebird_database)
  Define *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)
  Define.i nResult = fb_start(*db\sv, @*db\txh, 1, @*db\dbh, 4, *TPB)
  FreeMemory(*TPB)
  If nResult = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False   
  EndIf
EndProcedure

Procedure.i fbdb_commit(*db.firebird_database)
  Define.i nResult = fb_commit(*db\sv, @*db\txh)
  *db\txh = 0
  If nResult.i = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf  
EndProcedure

Procedure.i fbdb_rollback(*db.firebird_database)
  Res = fb_rollback(*db\sv, @*db\txh)
  *db\txh = 0
  If Res = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf 
EndProcedure

Procedure.s fbdb_error_message(*db.firebird_database)
  Define.s ErrorMessage = ""
  Define.i nResult = 1, *bfr
  While nResult <> 0
    *bfr = AllocateMemory(256)
    nResult.i   = fb_error(*bfr, 256, @*db\sv)
    ErrorMessage + PeekS(*bfr, -1, #PB_UTF8) + #CRLF$
    FreeMemory(*bfr)
  Wend
  If ErrorMessage = ""
    *bfr = AllocateMemory(256)
    Define.w nSQLCode = fb_sqlcode(*db\sv)
    If nSQLCode <> 0
      ErrorMessage = "SQL Code: " + Str(nSQLCode)
      fb_sql_error(nSQLCode, *bfr, 256)
      ErrorMessage + #CRLF$ + PeekS(*bfr, -1, #PB_UTF8)
    EndIf
    FreeMemory(*bfr)
  EndIf
  *db\sv = AllocateMemory(200) ;reading the status vector seems to mangle it (??)
  ProcedureReturn ErrorMessage
EndProcedure

Procedure fbdb_free(*db.firebird_database)
  FreeMemory(*db\sv)
  FreeStructure(*db)
EndProcedure

Procedure.i FirebirdDatabase()
  *db.firebird_database = AllocateStructure(firebird_database)
  *db\dbh       = 0
  *db\txh       = 0
  *db\error     = ""
  *db\sv        = AllocateMemory(200)
  *db\Begin     = @fbdb_begin()
  *db\Close     = @fbdb_close()
  *db\Commit    = @fbdb_commit()
  *db\Connect   = @fbdb_connect()
  *db\Cursor    = @fbdb_cursor()
  *db\Free      = @fbdb_free()
  *db\LastError = @fbdb_error_message()
  *db\Rollback  = @fbdb_rollback()
  ProcedureReturn *db
EndProcedure

;- cursor
Procedure fbcr_bind_double(*cr.firebird_cursor, idx, itm.d)
  Define.i nPos = *cr\bfr_in + _fb_position_pointer(idx)
  Define.i nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
  PokeD(nBfr, itm)
  *cr\bind_count + 1
EndProcedure

Procedure fbcr_bind_float(*cr.firebird_cursor, idx, itm.f)
  Define.i nPos = *cr\bfr_in + _fb_position_pointer(idx)
  Define.i nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
  PokeF(nBfr, itm) 
  *cr\bind_count + 1
EndProcedure

Procedure fbcr_bind_integer(*cr.firebird_cursor, idx, itm.i)
  Define.i nPos = *cr\bfr_in + _fb_position_pointer(idx)
  Define.i nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
  PokeI(nBfr, itm)
  *cr\bind_count + 1
EndProcedure

Procedure fbcr_bind_null(*cr.firebird_cursor, idx)
  Define.i nPos = *cr\bfr_in + _fb_position_pointer(idx)
  Define.i nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqlind))
  PokeW(nBfr, -1)
  *cr\bind_count + 1
EndProcedure

Procedure fbcr_bind_string(*cr.firebird_cursor, idx, itm.s)
  Define.i nPos = *cr\bfr_in + _fb_position_pointer(idx)
  Define.i nBfr = PeekI(nPos+OffsetOf(XSQLVAR\sqldata))
  Define.w nLen = StringByteLength(itm, #PB_UTF8)
  PokeW(nBfr, nLen)
  PokeS(nBfr+2, itm, nLen, #PB_UTF8)
  *cr\bind_count + 1
EndProcedure

Procedure.i fbcr_prepare(*cr.firebird_cursor, sql.s)
  Define.i nRes = fb_allocate(*cr\dbh\sv, @*cr\dbh\dbh, @*cr\stmt)
  If nRes <> 0 : ProcedureReturn #False : EndIf
  Define.i nFields = _fb_prepare(*cr\dbh\sv, *cr\dbh\txh, *cr\stmt, sql)
  If nFields = -1 : ProcedureReturn #False : EndIf
  *cr\bfr_in = AllocateMemory(_fb_buffer_size(1))
  nFields    = _fb_describe_bind(*cr\dbh\sv, *cr\stmt, *cr\bfr_in, 1)
  If nFields = -1
    FreeMemory(*cr\bfr_in)
    ProcedureReturn #False
  Else
    If nFields > 1
      FreeMemory(*cr\bfr_in)
      *cr\bfr_in = AllocateMemory(_fb_buffer_size(nFields))
      Define.i Res = _fb_describe_bind(*cr\dbh\sv, *cr\stmt, *cr\bfr_in, nFields)
      If Res = -1
        ProcedureReturn #False
      Else
        ProcedureReturn #True
      EndIf
    Else
      ProcedureReturn #True
    EndIf
  EndIf   
EndProcedure

Procedure.i fbcr_sql_execute(*cr.firebird_cursor, sql.s="")
  If *cr\bind_count > 0
    ProcedureReturn _fb_sql_executep(*cr)
  Else
    ProcedureReturn _fb_sql_execute(*cr, sql)
  EndIf
EndProcedure

Procedure.i fbcr_sql_select(*cr.firebird_cursor, sql.s="")
  If *cr\bind_count > 0
    ProcedureReturn _fb_sql_selectp(*cr)
  Else
    Define.i nRes = fb_allocate(*cr\dbh\sv, @*cr\dbh\dbh, @*cr\stmt)
    If nRes <> 0 : ProcedureReturn #Null : EndIf
    ProcedureReturn _fb_sql_select(*cr, sql)
  EndIf
EndProcedure

Procedure.i fbcr_free(*cr.firebird_cursor)
  If *cr\bfr_out <> #Null
    _fb_free_buffers(*cr\bfr_out)
  EndIf
  If *cr\bfr_in <> #Null
    _fb_free_buffers(*cr\bfr_in)
  EndIf    
  Define.i nRes = fb_free(*cr\dbh\sv, @*cr\stmt, #DSQL_DROP)
  If nRes = 0
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf  
EndProcedure

Procedure.i FirebirdCursor(*db.firebird_database)
  *cr.firebird_cursor = AllocateStructure(firebird_cursor)
  *cr\stmt        = 0
  *cr\bind_count  = 0
  *cr\bfr_in      = #Null
  *cr\bfr_out     = #Null
  *cr\dbh         = *db
  *cr\BindDouble  = @fbcr_bind_double()
  *cr\BindFloat   = @fbcr_bind_float()
  *cr\BindInteger = @fbcr_bind_integer()
  *cr\BindNull    = @fbcr_bind_null()
  *cr\BindString  = @fbcr_bind_string()
  *cr\Free        = @fbcr_free()
  *cr\Prepare     = @fbcr_prepare()
  *cr\SQLExecute  = @fbcr_sql_execute()
  *cr\SQLSelect   = @fbcr_sql_select()
  ProcedureReturn *cr
EndProcedure

;- recordset
Procedure fbrs_move_next(*rs.firebird_recordset)
  Define.i nRes = fb_fetch(*rs\cursor\dbh\sv, @*rs\cursor\stmt, 1, *rs\cursor\bfr_out)
  If nRes = 100
    ProcedureReturn #False
  ElseIf nRes = 0
    _fb_get_fields(*rs)
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

Procedure.i fbrs_field_count(*rs.firebird_recordset)
  Define.i nFieldCount = PeekW(*rs\cursor\bfr_out+OffsetOf(XSQLDA\sqld))
  ProcedureReturn nFieldCount
EndProcedure

Procedure.i fbrs_field_by_index(*rs.firebird_recordset, idx)
  ProcedureReturn SelectElement(*rs\fields(), idx)
EndProcedure

Procedure.i fbrs_field_by_name(*rs.firebird_recordset, fname.s)
  ResetList(*rs\fields())
  Define.i nLoop = 0, idx = -1
  While NextElement(*rs\fields())
    If LCase(*rs\fields()\name) = LCase(fname)
      idx = nLoop
    EndIf
    nLoop + 1
  Wend
  ProcedureReturn idx
EndProcedure

Procedure.s fbrs_field_name(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\name
EndProcedure

Procedure.i fbrs_field_type(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\type  
EndProcedure

Procedure.i fbrs_field_subtype(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\subtype  
EndProcedure

Procedure.i fbrs_field_size(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\size  
EndProcedure

Procedure.i fbrs_field_scale(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\scale  
EndProcedure

Procedure.i fbrs_field_length(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\length  
EndProcedure

Procedure.i fbrs_field_pbtype(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\pbtype  
EndProcedure

Procedure.i fbrs_field_isnull(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\isnull  
EndProcedure

Procedure.s fbrs_field_date(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\stringval  
EndProcedure

Procedure.d fbrs_field_double(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn ValD(*rs\fields()\stringval)
EndProcedure

Procedure.f fbrs_field_float(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn ValF(*rs\fields()\stringval) 
EndProcedure

Procedure.i fbrs_field_integer(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn Val(*rs\fields()\stringval) 
EndProcedure

Procedure.q fbrs_field_quad(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn Val(*rs\fields()\stringval)
EndProcedure

Procedure.s fbrs_field_string(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\stringval  
EndProcedure

Procedure.s fbrs_field_time(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\stringval  
EndProcedure

Procedure.s fbrs_field_timestamp(*rs.firebird_recordset, idx)
  SelectElement(*rs\fields(), idx)
  ProcedureReturn *rs\fields()\stringval  
EndProcedure

Procedure fbrs_free(*rs.firebird_recordset)
  *rs\cursor\Free(*rs\cursor)
  FreeStructure(*rs)
EndProcedure

Procedure.i FirebirdRecordSet(*cr.firebird_cursor)
  *rs.firebird_recordset = AllocateStructure(firebird_recordset)
  *rs\cursor           = *cr
  *rs\Fetch            = @fbrs_move_next()
  *rs\FieldByIndex     = @fbrs_field_by_index()
  *rs\FieldCount       = @fbrs_field_count()
  *rs\FieldDate        = @fbrs_field_date()
  *rs\FieldDouble      = @fbrs_field_double()
  *rs\FieldFloat       = @fbrs_field_float()
  *rs\FieldIndexByName = @fbrs_field_by_name()
  *rs\FieldInteger     = @fbrs_field_integer()
  *rs\FieldIsNull      = @fbrs_field_isnull()
  *rs\FieldLength      = @fbrs_field_length()
  *rs\FieldName        = @fbrs_field_name()
  *rs\FieldPBType      = @fbrs_field_pbtype()
  *rs\FieldQuad        = @fbrs_field_quad()
  *rs\FieldScale       = @fbrs_field_scale()
  *rs\FieldSize        = @fbrs_field_size()
  *rs\FieldString      = @fbrs_field_string()
  *rs\FieldSubtype     = @fbrs_field_subtype()
  *rs\FieldTime        = @fbrs_field_time()
  *rs\FieldTimestamp   = @fbrs_field_timestamp()
  *rs\FieldType        = @fbrs_field_type()
  *rs\Free             = @fbrs_free()
  ProcedureReturn *rs
EndProcedure
And an example of usage:

Code: Select all

XIncludeFile "fbdb.pb"

Procedure HandleError(*db.firebird_database)
  MessageRequester("Error", *db\LastError(*db), 0)
  If *db\txh <> 0
    *db\Rollback(*db)
  EndIf
  If *db\dbh <> 0
    *db\Close(*db)
  EndIf
  End
EndProcedure

; connect
*db.firebird_database = FirebirdDatabase()
If Not *db\Connect(*db, "localhost/3050:employee", "sysdba", "masterkey")
  HandleError(*db)
EndIf

; start a transaction
*db\Begin(*db)

; an update without parameters
*cs.firebird_cursor = *db\Cursor(*db)
If Not *cs\SQLExecute(*cs, "UPDATE COUNTRY SET CURRENCY = 'Euro' WHERE COUNTRY = 'Italy'")
  HandleError(*db)
EndIf
*cs\Free(*cs) ; free the cursor after an update

; an update with parameters
*cs.firebird_cursor = *db\Cursor(*db) ; create a new cursor every time
If Not *cs\Prepare(*cs, "UPDATE COUNTRY SET CURRENCY = 'Euro' WHERE COUNTRY = ?")
  HandleError(*db)
EndIf
*cs\BindString(*cs, 1, "France")
If Not *cs\SQLExecute(*cs) : HandleError(*db) : EndIf
*cs\Free(*cs)

; commit the transaction
*db\Commit(*db)

; a cursor always needs an active transaction handle
*db\Begin(*db)

; select without parameters
*cs = *db\Cursor(*db)
*rs.firebird_recordset = *cs\SQLSelect(*cs, "Select * From COUNTRY ORDER BY COUNTRY")
If *rs = #Null : HandleError(*db) : EndIf
Define.i nIter, nFieldCount = *rs\FieldCount(*rs)
While *rs\Fetch(*rs)
  nIter = 0
  While nIter < nFieldCount
    Define *fld.firebird_field = *rs\FieldByIndex(*rs, nIter)
    Debug *fld\stringval
    nIter + 1
  Wend
  Debug ""
Wend
*rs\Free(*rs) ; freeing a recordset also frees the associated cursor

; select with parameters
*cs = *db\Cursor(*db) ; create a new cursor every time
If Not *cs\Prepare(*cs, "Select * From EMPLOYEE Where JOB_COUNTRY = ? ORDER BY EMP_NO")
  HandleError(*db)
EndIf
*cs\BindString(*cs, 1, "USA")

*rs.firebird_recordset = *cs\SQLSelect(*cs)
If *rs = #Null : HandleError(*db) : EndIf
nFieldCount = *rs\FieldCount(*rs)
While *rs\Fetch(*rs)
  nIter = 0
  While nIter < nFieldCount
    If *rs\FieldIsNull(*rs, nIter)
      Debug "#Null"
    Else
      Select *rs\FieldPBType(*rs, nIter)
        Case #PB_Database_Double
          Debug *rs\FieldDouble(*rs, nIter)
        Case #PB_Database_Float
          Debug *rs\FieldFloat(*rs, nIter)
        Case #PB_Database_Long
          Debug *rs\FieldInteger(*rs, nIter)
        Case #PB_Database_Quad
          Debug *rs\FieldQuad(*rs, nIter)
        Case #PB_Database_String
          Debug *rs\FieldString(*rs, nIter)
        Default
          Select *rs\FieldType(*rs, nIter)
            Case #FB_SQL_TIMESTAMP, #FB_SQL_TYPE_DATE, #FB_SQL_TYPE_TIME
              Debug *rs\FieldString(*rs, nIter)
            Case #FB_SQL_TIMESTAMP + 1, #FB_SQL_TYPE_DATE + 1, #FB_SQL_TYPE_TIME + 1
              Debug *rs\FieldString(*rs, nIter)
            Default
              Debug "Unsupported type: " + Str(*fld\type)
          EndSelect
      EndSelect
    EndIf
    nIter + 1
  Wend
  Debug ""
Wend
*rs\Free(*rs) ; freeing a recordset also frees the related cursor

; finish with the transaction
*db\Rollback(*db)

; close the connection
*db\Close(*db)
Last edited by the.weavster on Sun Dec 04, 2022 3:40 pm, edited 3 times in total.
krisnin
New User
New User
Posts: 1
Joined: Sat Jun 20, 2009 9:38 am
Location: Philippines

Re: Firebird Database Server client module

Post by krisnin »

Hi the.weavster,

Thanks for sharing!

There's a memory leak because of un free memory..

Code: Select all

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) <---- assign a memory here
      PokeI(nPos+OffsetOf(XSQLVAR\sqldata), bfield)
      nPos = nPos + SizeOf(XSQLVAR)
    Next
  EndProcedure
  
  Procedure _free_buffers(*bfr)
    nFieldCount = PeekW(*bfr+OffsetOf(XSQLDA\sqld))
    nPos = *bfr + SizeOf(XSQLDA)
    For c = 1 To nFieldCount		
      nBuffer = PeekI(nPos+OffsetOf(XSQLVAR\sqldata)) <----but but not freeing memory here
      FreeMemory(nBuffer)
      nPos = nPos + SizeOf(XSQLVAR)
    Next
    FreeMemory(*bfr)
  EndProcedure
User avatar
the.weavster
Addict
Addict
Posts: 1537
Joined: Thu Jul 03, 2003 6:53 pm
Location: England

Re: Firebird Database Server client module

Post by the.weavster »

krisnin wrote: Sun Dec 04, 2022 4:42 am There's a memory leak because of un free memory..
Well spotted 👍️
Post Reply