Firebird Database Server client module
- holzhacker
- Enthusiast
- Posts: 123
- Joined: Mon Mar 08, 2010 9:14 pm
- Location: "Mens sana in corpore sano"
- Contact:
- the.weavster
- Addict
- Posts: 1537
- Joined: Thu Jul 03, 2003 6:53 pm
- Location: England
Re: Firebird Database Server client module
I've just created an alternative API which I personally prefer to my original module:
The declares [ fbdb-declares.pb ]
The wrapper [ fbdb.pb ]
And an example of usage:
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)
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
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.
Re: Firebird Database Server client module
Hi the.weavster,
Thanks for sharing!
There's a memory leak because of un free memory..
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
- the.weavster
- Addict
- Posts: 1537
- Joined: Thu Jul 03, 2003 6:53 pm
- Location: England