Interbase & Firebird : Wrapper Problem

thanos · Post by **thanos** » Mon Mar 16, 2009 10:42 pm

the.weavster wrote: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?

Thank you for the immediate response!
I am sorry, i was not as clear as needed

When i run the program from my local computer (name=MOBILE1) e.g. installed in C:\Program Files\Evolution everything is okay.
When i run the program via a remote desktop in my server (server name=PEGASUS) everything is also okay.
But when i map a network drive e.g. V:\Evolution which is the original path of \\PEGASUS\Data_Net\Evolution and trying to run the program i can not connect to the database.

the.weavster wrote: 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 already tried with the folowings:

Code: Select all

DBNAME=localhost:Evo_Demo;
DBNAME=PEGASUS:Evo_Demo;
DBNAME=192.168.0.10:Evo_Demo;

with the same bad results.

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

It is surely the same. In both computers.
Regards.

Thanos

the.weavster · Post by **the.weavster** » Mon Mar 16, 2009 11:28 pm

So is V:\Evolution the path as it appears to MOBILE1 rather than as it appears to PEGASUS?

If the Firebird server is running on PEGASUS the specified path to the database must be one PEGASUS can understand.

thanos · Post by **thanos** » Tue Mar 17, 2009 7:19 am

the.weavster wrote:So is V:\Evolution the path as it appears to MOBILE1 rather than as it appears to PEGASUS?

If the Firebird server is running on PEGASUS the specified path to the database must be one PEGASUS can understand.

Okay i understand it. Thank you.
Is there any way to connect from the client (MOBILE1) to the server (PEGASUS) by using the string \\PEGASUS\Data_Net\Evolution\Evo_Demo.fdb without mapping the above path as a drive letter?
Regards

Thanos

the.weavster · Post by **the.weavster** » Wed Mar 18, 2009 11:57 am

From MOBILE1 you should be able to specify your database as:

Code: Select all

DBNAME=192.168.0.10/3051:C:\Program Files\Evolution\Evo_Demo.fdb

or

DBNAME=PEGASUS/3051:C:\Program Files\Evolution\Evo_Demo.fdb

Where
192.168.0.10 is the IP address of PEGASUS,
3051 is the port and
C:\Program Files\Evolution\Evo_Demo.fdb is the path to the database as it appears to PEGASUS

I would still recommend creating an alias in the aliases.conf file on PEGASUS and using that in your connection string from MOBILE1 though.

thanos · Post by **thanos** » Wed Mar 18, 2009 8:50 pm

the.weavster wrote:From MOBILE1 you should be able to specify your database as:
Code: Select all
DBNAME=192.168.0.10/3051:C:\Program Files\Evolution\Evo_Demo.fdb

or

DBNAME=PEGASUS/3051:C:\Program Files\Evolution\Evo_Demo.fdb
Where
192.168.0.10 is the IP address of PEGASUS,
3051 is the port and
C:\Program Files\Evolution\Evo_Demo.fdb is the path to the database as it appears to PEGASUS

I would still recommend creating an alias in the aliases.conf file on PEGASUS and using that in your connection string from MOBILE1 though.

I will try to use aliases for the names.
Btw, do you have any background in the old Clipper language and its evolution named Harbour?
Regards.

Thanos

the.weavster · Post by **the.weavster** » Wed Mar 18, 2009 10:22 pm

thanos wrote:do you have any background in the old Clipper language

Many years ago, when having a shaven head was a choice on my behalf rather than being an imposition of nature, I did a short course on dBase III.

I also have a work colleague who has written numerous programs in Clipper so if you have a specific issue I may be able to get the answer for you.

thanos wrote:and its evolution named Harbour?

I'm on the xharbour.org mailing list but to be honest I've never even tried using it.

thanos · Post by **thanos** » Wed Mar 18, 2009 10:39 pm

the.weavster wrote:I also have a work colleague who has written numerous programs in Clipper so if you have a specific issue I may be able to get the answer for you.

Thanks a lot but it is not necessary. I was very experienced programmer in Clipper but i am not using this language anymore.

the.weavster wrote:I'm on the xharbour.org mailing list but to be honest I've never even tried using it.

The above was the point of my previous post:)
I think about of a possible "reincarnation" of the old Clipper apps with the help of Harbour or xHarbour.
But i do not know if it worth the effort.
I never used the Harbour or the xHarbour and i do not know if they are solid, working well etc.
Regards.

Thanos

thanos · Post by **thanos** » Sun Mar 29, 2009 7:00 pm

the.weavster wrote:From MOBILE1 you should be able to specify your database as:
Code: Select all
DBNAME=192.168.0.10/3051:C:\Program Files\Evolution\Evo_Demo.fdb

or

DBNAME=PEGASUS/3051:C:\Program Files\Evolution\Evo_Demo.fdb
Where
192.168.0.10 is the IP address of PEGASUS,
3051 is the port and
C:\Program Files\Evolution\Evo_Demo.fdb is the path to the database as it appears to PEGASUS

I would still recommend creating an alias in the aliases.conf file on PEGASUS and using that in your connection string from MOBILE1 though.

I used aliases for my databases files. You are right!
They are easier to handle.
I have the server named PEGASUS which is running the Firebird server and holds the aliases.conf in its Firebird's directory.
Question 1: Must i write the aliases.conf in every client's Firebird directory?
Question 2: Is it necessary to install the Firebird server in every client? Is there any way to avoid this?
Regards.

Thanos

the.weavster · Post by **the.weavster** » Sun Mar 29, 2009 9:45 pm

thanos wrote:Must i write the aliases.conf in every client's Firebird directory?

No, only the servers.

thanos wrote:Is it necessary to install the Firebird server in every client?

No but iirc it's the same installer that does every job. If you're doing a client install just select 'Minimal Client Install' from the installers' combo box.

You do need to do a client install as described above before installing the ODBC driver (which you have to download separately).

If you do not opt to install fbclient.dll in the Windows system directory during the install you will have to point the driver at it's location when you set up a DSN though (it's the field labelled 'Client' in the FireBird DSN set up dialog, just click browse and navigate to the folder containing fbclient.dll).

thanos · Post by **thanos** » Mon Mar 30, 2009 6:40 pm

the.weavster wrote:
thanos wrote:Is it necessary to install the Firebird server in every client?
No but iirc it's the same installer that does every job. If you're doing a client install just select 'Minimal Client Install' from the installers' combo box.

You do need to do a client install as described above before installing the ODBC driver (which you have to download separately).

If you do not opt to install fbclient.dll in the Windows system directory during the install you will have to point the driver at it's location when you set up a DSN though (it's the field labelled 'Client' in the FireBird DSN set up dialog, just click browse and navigate to the folder containing fbclient.dll).

Thanks for the response.
I will try it to my network.
As i saw, for the client installation, the only file which is written by the installer is thw fbclient.dll
Is it enough, to make the installation procedure simpler, to copy the fbclient.dll int the windows system directory?
Regards.

Thanos

the.weavster · Post by **the.weavster** » Mon Mar 30, 2009 7:44 pm

thanos wrote:Is it enough, to make the installation procedure simpler, to copy the fbclient.dll int the windows system directory?

I'm afraid not.

rko · Post by **rko** » Mon Apr 12, 2010 7:46 am

i took liberty to add some stuff to your code. seems like the wrapper crashes on tables with a large number of columns and data.
does someone have some experience with that or even better a bugfix?

rko

Code: Select all

#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

#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
#isc_info_db_id                  = 4
#isc_info_reads                  = 5
#isc_info_writes             = 6
#isc_info_fetches                = 7
#isc_info_marks                  = 8
#isc_info_implementation = 11
#isc_info_isc_version            = 12
#isc_info_base_level             = 13
#isc_info_page_size              = 14
#isc_info_num_buffers    = 15
#isc_info_limbo                  = 16
#isc_info_current_memory = 17
#isc_info_max_memory             = 18
#isc_info_window_turns   = 19
#isc_info_license                = 20
#isc_info_allocation             = 21
#isc_info_attachment_id   = 22
#isc_info_read_seq_count = 23
#isc_info_read_idx_count = 24
#isc_info_insert_count           = 25
#isc_info_update_count           = 26
#isc_info_delete_count           = 27
#isc_info_backout_count          = 28
#isc_info_purge_count            = 29
#isc_info_expunge_count          = 30
#isc_info_sweep_interval = 31
#isc_info_ods_version            = 32
#isc_info_ods_minor_version      = 33
#isc_info_no_reserve             = 34
#isc_info_logfile                = 35
#isc_info_cur_logfile_name       = 36
#isc_info_cur_log_part_offset    = 37
#isc_info_num_wal_buffers        = 38
#isc_info_wal_buffer_size        = 39
#isc_info_wal_ckpt_length        = 40

#isc_info_wal_cur_ckpt_interval = 41
#isc_info_wal_prv_ckpt_fname     = 42
#isc_info_wal_prv_ckpt_poffset   = 43
#isc_info_wal_recv_ckpt_fname    = 44
#isc_info_wal_recv_ckpt_poffset = 45
#isc_info_wal_grpc_wait_usecs    = 47
#isc_info_wal_num_io             = 48
#isc_info_wal_avg_io_size        = 49
#isc_info_wal_num_commits        = 50
#isc_info_wal_avg_grpc_size      = 51
#isc_info_forced_writes          = 52
#isc_info_user_names = 53
#isc_info_page_errors = 54
#isc_info_record_errors = 55
#isc_info_bpage_errors = 56
#isc_info_dpage_errors = 57
#isc_info_ipage_errors = 58
#isc_info_ppage_errors = 59
#isc_info_tpage_errors = 60
#isc_info_set_page_buffers = 61
#isc_info_db_sql_dialect = 62   
#isc_info_db_read_only = 63
#isc_info_db_size_in_pages = 64
#isc_info_db_class = 102
#isc_info_firebird_version = 103
#isc_info_oldest_transaction = 104
#isc_info_oldest_active = 105
#isc_info_oldest_snapshot = 106
#isc_info_next_transaction = 107
#isc_info_db_provider = 108
#isc_info_active_transactions = 109
#isc_info_active_tran_count = 110
#isc_info_creation_date = 111
#isc_info_db_last_value =112  

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

Structure DBINFOS
  Fetches.l 
  Marks.l 
  Reads.l 
  Writes.l
  Dialect.l
  ODSMajor.l
  ODSMinor.l
  PageSizes.l
  Pages.l
  Buffers.l
  Sweep.l
  Sync.l
  Reserve.l
  Inserts.l
  Update.l
  Deletes.l
  ReadIdx.l
  ReadSeq.l
EndStructure

;- 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
;- 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
;- 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

Structure blobInfos
  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


CompilerSelect #PB_Compiler_OS
  CompilerCase #PB_OS_Windows
    CompilerSelect #PB_Compiler_Processor
      CompilerCase #PB_Processor_x86 
        sLibrary.s = "fbclient.dll"
        EndOfLine = Chr(13) + Chr(10)
      CompilerCase #PB_Processor_x64
        sLibrary.s = "fbclient64.dll"
        EndOfLine = Chr(13) + Chr(10)
    CompilerEndSelect
  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

Prototype isc_encode_sql_date(*tm_date.tm, *ISC_DATE.q)
Global fb_encodedate.isc_encode_sql_date
Prototype isc_encode_timestamp(*tm_date.tm, *ISC_TIMESTAMP.q)
Global fb_encodetimestamp.isc_encode_timestamp
Prototype isc_encode_sql_time(*tm_date.tm, *ISC_TIME.q)
Global fb_encodetime.isc_encode_sql_time
Prototype isc_decode_date(*ISC_DATE.q, *tm_date.tm)
Global fb_decodedate.isc_decode_date
Prototype isc_decode_timestamp(*ISC_TIMESTAMP.q, *tm_date.tm)
Global fb_decodetimestamp.isc_decode_timestamp
Prototype isc_decode_sql_time(*ISC_TIME.q, *tm_date.tm)
Global fb_decodetime.isc_decode_sql_time

Prototype.i isc_open_blob2(*StatusVector,*dbHandle,*TransactionHandle,*BlobHandle,*ISC_QUAD,ISC_USHORT.w,*Sstring)
Global fb_openblob.isc_open_blob2
Prototype.i isc_cancel_blob(*StatusVector,*BlobHandle)
Global fb_cancelblob.isc_cancel_blob
Prototype.i isc_create_blob2(*StatusVector,*dbHandle,*TransactionHandle,*BlobHandle,*ISC_QUAD,short.w,*Sstring)
Global fb_createblob.isc_create_blob2
Prototype.i isc_close_blob(*StatusVector,*BlobHandle)
Global fb_closeblob.isc_close_blob
Prototype.i isc_blob_info(*StatusVector,*BlobHandle,sshort.w,*Sstring,short.w,*Sstring1)
Global fb_infoblob.isc_blob_info
Prototype.i isc_get_segment(*StatusVector,*BlobHandle,*unsignedshort,ushort.w,*Sstring)
Global fb_getsegment.isc_get_segment
Prototype.i isc_put_segment(*StatusVector,*BlobHandle,ushort.w,*Sstring)
Global fb_putsegment.isc_put_segment
Prototype.l isc_vax_integer(*Sstring,short.w)
Global fb_vaxinteger.isc_vax_integer

Prototype.i isc_database_info(*StatusVector,*dbHandle, short.w,*ISC_SCHAR,shortt.w, *IISC_SCHAR)
Global fb_dbinfo.isc_database_info

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 
  fb_encodedate = GetFunction(#FB_Client,"isc_encode_sql_date")
  fb_encodetimestamp = GetFunction(#FB_Client,"isc_encode_timestamp")
  fb_encodetime = GetFunction(#FB_Client,"isc_encode_sql_time")
  fb_decodedate = GetFunction(#FB_Client,"isc_decode_date")
  fb_decodetimestamp = GetFunction(#FB_Client,"isc_decode_timestamp")
  fb_decodetime = GetFunction(#FB_Client,"isc_decode_sql_time")
  fb_openblob = GetFunction(#FB_Client,"isc_open_blob2")
  fb_cancelblob = GetFunction(#FB_Client,"isc_cancel_blob")
  fb_createblob = GetFunction(#FB_Client,"isc_create_blob2")
  fb_closeblob = GetFunction(#FB_Client,"isc_close_blob")
  fb_cancelblob = GetFunction(#FB_Client,"isc_cancel_blob")
  fb_infoblob = GetFunction(#FB_Client,"isc_blob_info")
  fb_getsegment = GetFunction(#FB_Client,"isc_get_segment")
  fb_putsegment = GetFunction(#FB_Client,"isc_put_segment")
  fb_vaxinteger = GetFunction(#FB_Client,"isc_vax_integer")
  fb_dbinfo = GetFunction(#FB_Client,"isc_database_info")
Else
  MessageRequester("Error","Library not found",0)
  End
EndIf

Global NewList fbDB.fbDatabase()
Global NewList fbRS.fbRecordSet()
Global NewList fbFld.fbField()

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

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.l ResultbufferFindToken(*ResultbufferVector, token.i)
  i = 0 : lens = 0
  While PeekB(*ResultbufferVector+i) <> #isc_info_end
    If PeekB(*ResultbufferVector+i) = token 
      ProcedureReturn i+1
    EndIf
    lens = fb_vaxinteger(*ResultbufferVector+i+1, 2)
    i = i + lens + 3
  Wend
  ProcedureReturn -1
EndProcedure

Procedure.l ResultbufferGetValue(*ResultbufferVector, token.i)
  value = 0
  p = ResultbufferFindToken(*ResultbufferVector, token)
  If p = -1 
    ProcedureReturn -1
  EndIf
  lens = fb_vaxinteger(*ResultbufferVector+p, 2)
  If lens = 0 
    value = 0
  Else
    value = fb_vaxinteger(*ResultbufferVector+p + 2, lens)
  EndIf
  ProcedureReturn value
EndProcedure

Procedure.i ResultbufferGetCountValue(*ResultbufferVector,token.i) ; Specifically used on tokens like isc_info_insert_count and the like which return detailed counts per relation. We sum up the values.
  value = 0
  p = ResultbufferFindToken(*ResultbufferVector, token)
  If i = -1 
    ProcedureReturn  -1
  EndIf
  i = 0
  lens = fb_vaxinteger(*ResultbufferVector+p, 2) ;len is the number of bytes in the following array
  i = i + 3
  value = 0
  While lens > 0  ; Each array item is 6 bytes : 2 bytes for the relation_id which we skip, and 4 bytes for the count value which we sum up accross all tables.
      value = value + fb_vaxinteger(*ResultbufferVector+p+2, 4)
      i = i + 6
      lens = lens - 6
  Wend
  ProcedureReturn value
EndProcedure

Procedure.i Statistics(*dbHandle, *dbbinfo.DBINFOS)
  *TPB = AllocateMemory(5)
  PokeB(*TPB + 0,#isc_info_fetches)
  PokeB(*TPB + 1,#isc_info_marks)
  PokeB(*TPB + 2,#isc_info_reads)
  PokeB(*TPB + 3,#isc_info_writes)
  PokeB(*TPB + 4,#isc_info_end)
  *resbuffer = AllocateMemory(128)
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 5, *TPB, 128,  *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\Fetches = ResultbufferGetValue(*resbuffer, #isc_info_fetches)
  *dbbinfo\Marks = ResultbufferGetValue(*resbuffer, #isc_info_marks)
  *dbbinfo\Reads = ResultbufferGetValue(*resbuffer, #isc_info_reads)
  *dbbinfo\Writes = ResultbufferGetValue(*resbuffer, #isc_info_writes)
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure


Procedure.i Info(*dbHandle,*dbbinfo.DBINFOS)
  *TPB = AllocateMemory(10)
  PokeB(*TPB + 0,#isc_info_ods_version)
  PokeB(*TPB + 1,#isc_info_ods_minor_version)
  PokeB(*TPB + 2,#isc_info_page_size)
  PokeB(*TPB + 3,#isc_info_allocation)
  PokeB(*TPB + 4,#isc_info_num_buffers)
  PokeB(*TPB + 5,#isc_info_sweep_interval)
  PokeB(*TPB + 6,#isc_info_forced_writes)
  PokeB(*TPB + 7,#isc_info_no_reserve)
  PokeB(*TPB + 8,#isc_info_db_sql_dialect)
  PokeB(*TPB + 9,#isc_info_end)
  *resbuffer = AllocateMemory(256)       
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 10, *TPB, 256, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\ODSMajor = ResultbufferGetValue(*resbuffer, #isc_info_ods_version)
  *dbbinfo\ODSMinor = ResultbufferGetValue(*resbuffer, #isc_info_ods_minor_version)
  *dbbinfo\PageSizes = ResultbufferGetValue(*resbuffer, #isc_info_page_size)
  *dbbinfo\Pages = ResultbufferGetValue(*resbuffer, #isc_info_allocation)
  *dbbinfo\Buffers = ResultbufferGetValue(*resbuffer, #isc_info_num_buffers)
  *dbbinfo\Sweep = ResultbufferGetValue(*resbuffer, #isc_info_sweep_interval)
  *dbbinfo\Sync = ResultbufferGetValue(*resbuffer, #isc_info_forced_writes)
  *dbbinfo\Reserve = ResultbufferGetValue(*resbuffer, #isc_info_no_reserve)
  *dbbinfo\Dialect = ResultbufferGetValue(*resbuffer, #isc_info_db_sql_dialect)
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure

Procedure.i Counts(*dbHandle,*dbbinfo.DBINFOS)
  *TPB = AllocateMemory(6)
  PokeB(*TPB + 0,#isc_info_insert_count)
  PokeB(*TPB + 1,#isc_info_update_count)
  PokeB(*TPB + 2,#isc_info_delete_count)
  PokeB(*TPB + 3,#isc_info_read_idx_count)
  PokeB(*TPB + 4,#isc_info_read_seq_count)
  PokeB(*TPB + 5,#isc_info_end)
  *resbuffer = AllocateMemory(1024)       
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 6, *TPB, 1024, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\Inserts = ResultbufferGetCountValue(*resbuffer, #isc_info_insert_count)
  *dbbinfo\Update = ResultbufferGetCountValue(*resbuffer, #isc_info_update_count)
  *dbbinfo\Deletes = ResultbufferGetCountValue(*resbuffer, #isc_info_delete_count)
  *dbbinfo\ReadIdx = ResultbufferGetCountValue(*resbuffer, #isc_info_read_idx_count)
  *dbbinfo\ReadSeq = ResultbufferGetCountValue(*resbuffer, #isc_info_read_seq_count)
  ProcedureReturn #True
EndProcedure

Procedure.s DBUsers(*dbHandle)
  *TPB = AllocateMemory(2)
  PokeB(*TPB + 0,#isc_info_user_names)
  PokeB(*TPB + 1,#isc_info_end)
  *resbuffer = AllocateMemory(8000)  
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 2, *TPB, 8000, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn ""
  EndIf
  i = 0 : j = 0 : usrs.s = "|" : x.s = ""
  While PeekB(*resbuffer+i) = #isc_info_user_names
    i = i + 3   ;Get to the length byte(there are two undocumented bytes which we skip)
    lens.i = PeekB(*resbuffer+i) 
    i = i + 1   ;Get to the first char of username
    If lens <> 0 
      x = ""
      For k = i To i + (lens-1)
        x = x + CHR(PeekB(*resbuffer+k)) 
      Next k
      usrs = usrs + x + "|"
      j = j + 1
    EndIf
    i = i + lens ;Skip username
  Wend
  FreeMemory(*resbuffer)
  ProcedureReturn usrs
EndProcedure

Procedure.i InfoBlob(*blobi.blobInfos)
  *TPB = AllocateMemory(4)
  PokeB(*TPB + 0,#isc_info_blob_total_length)
  PokeB(*TPB + 1,#isc_info_blob_max_segment)
  PokeB(*TPB + 2,#isc_info_blob_num_segments)
  PokeB(*TPB + 3,#isc_info_blob_type)
  *resbuffer = AllocateMemory(128)
  lresult = fb_infoblob(@sv.ISC_STATUS, @*blobi\BlobHandle, 4, *TPB, 128, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\Sizes = ResultbufferGetValue(*resbuffer, #isc_info_blob_total_length)
  *blobi\Largest = ResultbufferGetValue(*resbuffer, #isc_info_blob_max_segment)
  *blobi\Segments = ResultbufferGetValue(*resbuffer, #isc_info_blob_num_segments)
  *blobi\Blobtype = ResultbufferGetValue(*resbuffer, #isc_info_blob_type) 
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure

Procedure CloseBlob(*blobhandle, writeMode.i)
  If *blobhandle <> 0 
    If writeMode = #False
      dum = fb_closeblob(@sv.ISC_STATUS, *blobhandle)
    Else
      dum = fb_cancelblob(@sv.ISC_STATUS, *blobhandle)
    EndIf
  EndIf
  If dum <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure CancelBlob(*blobhandle)
  dum = fb_cancelblob(@sv.ISC_STATUS, *blobhandle)
  If dum <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure.i CreateBlob(*blobi.blobInfos)
  lresult = fb_createblob(@sv.ISC_STATUS,@*blobi\DatabaseID, @*blobi\TransactionID,@*blobi\BlobHandle,@*blobi\BlobID, 0, 0)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #True
  ProcedureReturn #True
EndProcedure

Procedure.i OpenBlob(*blobi.blobInfos)
  lresult = fb_openblob(@sv.ISC_STATUS, @*blobi\DatabaseID, @*blobi\TransactionID, @*blobi\BlobHandle, @*blobi\BlobID, 0, 0)
  If lresult <> 0
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #False
  lresult = InfoBlob(*blobi.blobInfos)
  If lresult = #True 
    *blobi\BytesToRW = *blobi\Sizes / *blobi\Segments
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure.i ReadBlob(*blobi.blobInfos, *buffer)
  If *blobi\Sizes > (64*1024-1)
      fb_LastErrorMessage = "ReadBlob sizes too large"
      ProcedureReturn -1
  EndIf
  lresult = fb_getsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\BytesRW, @*blobi\BytesToRW, *buffer)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn 0
  EndIf
  If lresult <> #isc_segment And (lresult <> 0)
      fb_LastErrorMessage = "Blob - Read status isc_get_segment failed."
      ProcedureReturn -1
  EndIf
  ProcedureReturn *blobi\BytesRW
EndProcedure

Procedure.i WriteBlob(*blobi.blobInfos, *buffer)
  If *blobi\Sizes > (64*1024-1)
      fb_LastErrorMessage = "WriteBlob sizes too large"
      ProcedureReturn #False
  EndIf
  lresult = fb_putsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\Sizes, *buffer)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure
  
Procedure.i SaveBlob(*blobi.blobInfos, *datas)
  lresult = fb_createblob(@sv.ISC_STATUS,@*blobi\DatabaseID, @*blobi\TransactionID,@*blobi\BlobHandle,@*blobi\BlobID, 0, 0)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #True
  poss = 0
  While *blobi\BytesRW <> 0
      If *blobi\BytesRW < 32*1024-1
        blklen = *blobi\BytesRW
      Else
        blklen = 32*1024-1
      EndIf
      lresult = fb_putsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, blklen, *datas + poss)
      If lresult <> 0 
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False
      EndIf
      poss = poss + blklen
      *blobi\BytesRW = *blobi\BytesRW - blklen
  Wend
  lresult = CloseBlob(@*blobi\BlobHandle, *blobi\WriteMode)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  blobhandle = 0
  ProcedureReturn #True
EndProcedure

Procedure.i LoadBlob(*blobi.blobInfos, *datas)
  lresult = OpenBlob(*blobi.blobInfos)
  If lresult <> 0 
    fb_LastErrorMessage = "LoadBlob OpenBlob failed."
    ProcedureReturn #False
  EndIf
  mWriteMode = #False
  blklen = 32*1024-1
  datas = AllocateMemory(blklen)
  sizes = 0
  poss = 0
  Repeat
    lresult = fb_getsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\BytesRW, blklen, *datas + poss)
      If lresult = #isc_segstr_eof 
          Break ;  End of blob
      EndIf
      If lresult <> #isc_segment And lresult <> 0
          fb_LastErrorMessage = "LoadBlob isc_get_segment failed."
          ProcedureReturn #False
      EndIf
      poss = poss + bytesread
      sizes = sizes + bytesread
;;;;;;;;;;;;;;;      ReDim datas(ArraySize(datas()) + sizes + blklen)
  Until 1
  ReAllocateMemory(*datas, sizes)
  lresult = CloseBlob(@*blobi\BlobHandle, *blobi\WriteMode)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  blobhandle = 0
  ProcedureReturn #True
EndProcedure

Procedure.s xfb_decodeDate(*ISC_DATE.q, *tm_date.tm)
  fb_decodedate(*ISC_DATE, *tm_date)
  *tm_date\tm_mon = *tm_date\tm_mon + 1
  *tm_date\tm_year = *tm_date\tm_year + 1900
  ProcedureReturn STR(*tm_date\tm_mon) + "-" + STR(*tm_date\tm_mday)+ "-" + STR(*tm_date\tm_year)
EndProcedure

Procedure.s xfb_decodeTime(*ISC_TIME.q, *tm_date.tm)
  fb_decodetime(*ISC_TIME, *tm_date)
  ProcedureReturn STR(*tm_date\tm_hour) + ":" + STR(*tm_date\tm_min) + ":" + STR(*tm_date\tm_sec) 
EndProcedure

Procedure.s xfb_decodeTimestamp(*ISC_TIMESTAMP.q, *tm_date.tm)
  fb_decodetimestamp(*ISC_TIMESTAMP, *tm_date)
  *tm_date\tm_mon = *tm_date\tm_mon + 1
  *tm_date\tm_year = *tm_date\tm_year + 1900
  ProcedureReturn STR(*tm_date\tm_mon) + "-" + STR(*tm_date\tm_mday)+ "-" + STR(*tm_date\tm_year) + " " + STR(*tm_date\tm_hour) + ":" + STR(*tm_date\tm_min) + ":" + STR(*tm_date\tm_sec)
EndProcedure

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.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+1)
      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_Ascii)
  lAlias.w = StringByteLength(DatabaseAlias,dbEncoding)
  *dbAlias = AllocateMemory(lAlias+1)
  PokeS(*dbAlias,DatabaseAlias,lAlias,dbEncoding)
  sParam.s = Chr(#isc_dpb_version1)
  lUN.w = StringByteLength(Username,dbEncoding)
  If lUN > 0
    sParam = sParam + Chr(#isc_dpb_user_name) + Chr(lUN) + Username
  EndIf
  lPWD.w = StringByteLength(Password,dbEncoding)
  If lPWD > 0
    sParam = sParam + Chr(#isc_dpb_password) + Chr(lPWD) + Password
  EndIf
  lUN = StringByteLength(sParam,dbEncoding)
  *dbParam = AllocateMemory(lUN+1)
  PokeS(*dbParam,sParam,lUN,dbEncoding)
  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 = ListSize(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


Procedure.i fb_GetRecordset(RecordsetID)
  ResetList(fbRS())
  i=0
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RecordsetID
      ProcedureReturn i
    EndIf
    i = i +1
  Wend
  fb_LastErrorMessage = "fb_GetRecordset() - Invalid Recordset ID"
  ProcedureReturn -1 
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)
  tm_date.tm
  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
        qSize.q = PeekQ(fbFld()\BufferAddress)
        xfb_decodeTime(@qSize, @tm_date)
        sText.s = Str(iSize)
      Case #SQL_TYPE_DATE, #SQL_TYPE_DATE + 1, #SQL_DATE, #SQL_DATE + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = xfb_decodeDate(@qSize, @tm_date)
      Case #SQL_TIMESTAMP, #SQL_TIMESTAMP + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = xfb_decodeTimestamp(@qSize, @tm_date)
      ;- haven't done blobs or arrays yet, this will just return the ID     
      Case #SQL_BLOB, #SQL_BLOB + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        
        bi.blobInfos\BlobID = qSize
        i.i = fb_GetRecordset(RecordsetID)
        SelectElement(fbRS(), Position)
        bi\DatabaseID = fbRS()\DatabaseID
        bi\TransactionID = fbRS()\TransactionID
        bi\WriteMode = 0
        OpenBlob(@bi)
        buffer.s = Space(90)
        ReadBlob(@bi, @buffer)
        CloseBlob(@bi\BlobHandle, bi\WriteMode)
        sText.s = buffer        
      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:G:\datenbanken-evident\praxis.fdb","sysdba","masterkey",#PB_Ascii)
If db = -1
  MessageRequester("Error",fb_LastErrormessage,0)
Else
  
  Statistics(@db, @dbbinfo.DBINFOS)
  Info(@db,@dbbinfo)
  Counts(@db,@dbbinfo)
  users.s = DBUsers(@db)
  lTransID = fb_StartTransaction(db)
  If lTransID = -1
    MessageRequester("Error",fb_LastErrormessage,0)
  Else
      iRecordSet = fb_SQLSelect(db,lTransID,"SELECT * FROM PATBILD;")
      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.weavster · Post by **the.weavster** » Thu Jul 15, 2010 11:11 am

Hi rko, Sorry I didn't respond to you sooner but I only just noticed you'd posted to this old thread.

The code I posted was pretty much untested so it may have bugs, having said that I just ran the example using a table with 24 columns and 200,000 records and had no problems.

If the table your experiencing failure with doesn't contain private data maybe I could have a copy to see if I can figure out what the problem is.

Weave.

rko · Post by **rko** » Sun Nov 07, 2010 4:14 pm

sorry, haven't be arround for longer time. the table failed with blobs and i think i fixed the problem. i added some stuff to read metadata, that i needed to write some schema data. probably the list with the meta data should be hashes - but it worked for this way. i post the whole thing again:

Code: Select all

#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

#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
#isc_info_db_id                  = 4
#isc_info_reads                  = 5
#isc_info_writes             = 6
#isc_info_fetches                = 7
#isc_info_marks                  = 8
#isc_info_implementation = 11
#isc_info_isc_version            = 12
#isc_info_base_level             = 13
#isc_info_page_size              = 14
#isc_info_num_buffers    = 15
#isc_info_limbo                  = 16
#isc_info_current_memory = 17
#isc_info_max_memory             = 18
#isc_info_window_turns   = 19
#isc_info_license                = 20
#isc_info_allocation             = 21
#isc_info_attachment_id   = 22
#isc_info_read_seq_count = 23
#isc_info_read_idx_count = 24
#isc_info_insert_count           = 25
#isc_info_update_count           = 26
#isc_info_delete_count           = 27
#isc_info_backout_count          = 28
#isc_info_purge_count            = 29
#isc_info_expunge_count          = 30
#isc_info_sweep_interval = 31
#isc_info_ods_version            = 32
#isc_info_ods_minor_version      = 33
#isc_info_no_reserve             = 34
#isc_info_logfile                = 35
#isc_info_cur_logfile_name       = 36
#isc_info_cur_log_part_offset    = 37
#isc_info_num_wal_buffers        = 38
#isc_info_wal_buffer_size        = 39
#isc_info_wal_ckpt_length        = 40

#isc_info_wal_cur_ckpt_interval = 41
#isc_info_wal_prv_ckpt_fname     = 42
#isc_info_wal_prv_ckpt_poffset   = 43
#isc_info_wal_recv_ckpt_fname    = 44
#isc_info_wal_recv_ckpt_poffset = 45
#isc_info_wal_grpc_wait_usecs    = 47
#isc_info_wal_num_io             = 48
#isc_info_wal_avg_io_size        = 49
#isc_info_wal_num_commits        = 50
#isc_info_wal_avg_grpc_size      = 51
#isc_info_forced_writes          = 52
#isc_info_user_names = 53
#isc_info_page_errors = 54
#isc_info_record_errors = 55
#isc_info_bpage_errors = 56
#isc_info_dpage_errors = 57
#isc_info_ipage_errors = 58
#isc_info_ppage_errors = 59
#isc_info_tpage_errors = 60
#isc_info_set_page_buffers = 61
#isc_info_db_sql_dialect = 62   
#isc_info_db_read_only = 63
#isc_info_db_size_in_pages = 64
#isc_info_db_class = 102
#isc_info_firebird_version = 103
#isc_info_oldest_transaction = 104
#isc_info_oldest_active = 105
#isc_info_oldest_snapshot = 106
#isc_info_next_transaction = 107
#isc_info_db_provider = 108
#isc_info_active_transactions = 109
#isc_info_active_tran_count = 110
#isc_info_creation_date = 111
#isc_info_db_last_value =112  

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

Structure DBINFOS
  Fetches.l 
  Marks.l 
  Reads.l 
  Writes.l
  Dialect.l
  ODSMajor.l
  ODSMinor.l
  PageSizes.l
  Pages.l
  Buffers.l
  Sweep.l
  Sync.l
  Reserve.l
  Inserts.l
  Update.l
  Deletes.l
  ReadIdx.l
  ReadSeq.l
EndStructure

;- 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
;- 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
;- 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

Structure blobInfos
  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


CompilerSelect #PB_Compiler_OS
  CompilerCase #PB_OS_Windows
    CompilerSelect #PB_Compiler_Processor
      CompilerCase #PB_Processor_x86 
        sLibrary.s = "fbclient.dll"
        EndOfLine = Chr(13) + Chr(10)
      CompilerCase #PB_Processor_x64
        sLibrary.s = "fbclient64.dll"
        EndOfLine = Chr(13) + Chr(10)
    CompilerEndSelect
  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

Prototype isc_encode_sql_date(*tm_date.tm, *ISC_DATE.q)
Global fb_encodedate.isc_encode_sql_date
Prototype isc_encode_timestamp(*tm_date.tm, *ISC_TIMESTAMP.q)
Global fb_encodetimestamp.isc_encode_timestamp
Prototype isc_encode_sql_time(*tm_date.tm, *ISC_TIME.q)
Global fb_encodetime.isc_encode_sql_time
Prototype isc_decode_date(*ISC_DATE.q, *tm_date.tm)
Global fb_decodedate.isc_decode_date
Prototype isc_decode_timestamp(*ISC_TIMESTAMP.q, *tm_date.tm)
Global fb_decodetimestamp.isc_decode_timestamp
Prototype isc_decode_sql_time(*ISC_TIME.q, *tm_date.tm)
Global fb_decodetime.isc_decode_sql_time

Prototype.i isc_open_blob2(*StatusVector,*dbHandle,*TransactionHandle,*BlobHandle,*ISC_QUAD,ISC_USHORT.w,*Sstring)
Global fb_openblob.isc_open_blob2
Prototype.i isc_cancel_blob(*StatusVector,*BlobHandle)
Global fb_cancelblob.isc_cancel_blob
Prototype.i isc_create_blob2(*StatusVector,*dbHandle,*TransactionHandle,*BlobHandle,*ISC_QUAD,short.w,*Sstring)
Global fb_createblob.isc_create_blob2
Prototype.i isc_close_blob(*StatusVector,*BlobHandle)
Global fb_closeblob.isc_close_blob
Prototype.i isc_blob_info(*StatusVector,*BlobHandle,sshort.w,*Sstring,short.w,*Sstring1)
Global fb_infoblob.isc_blob_info
Prototype.i isc_get_segment(*StatusVector,*BlobHandle,*unsignedshort,ushort.w,*Sstring)
Global fb_getsegment.isc_get_segment
Prototype.i isc_put_segment(*StatusVector,*BlobHandle,ushort.w,*Sstring)
Global fb_putsegment.isc_put_segment
Prototype.l isc_vax_integer(*Sstring,short.w)
Global fb_vaxinteger.isc_vax_integer

Prototype.i isc_database_info(*StatusVector,*dbHandle, short.w,*ISC_SCHAR,shortt.w, *IISC_SCHAR)
Global fb_dbinfo.isc_database_info

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 
  fb_encodedate = GetFunction(#FB_Client,"isc_encode_sql_date")
  fb_encodetimestamp = GetFunction(#FB_Client,"isc_encode_timestamp")
  fb_encodetime = GetFunction(#FB_Client,"isc_encode_sql_time")
  fb_decodedate = GetFunction(#FB_Client,"isc_decode_date")
  fb_decodetimestamp = GetFunction(#FB_Client,"isc_decode_timestamp")
  fb_decodetime = GetFunction(#FB_Client,"isc_decode_sql_time")
  fb_openblob = GetFunction(#FB_Client,"isc_open_blob2")
  fb_cancelblob = GetFunction(#FB_Client,"isc_cancel_blob")
  fb_createblob = GetFunction(#FB_Client,"isc_create_blob2")
  fb_closeblob = GetFunction(#FB_Client,"isc_close_blob")
  fb_cancelblob = GetFunction(#FB_Client,"isc_cancel_blob")
  fb_infoblob = GetFunction(#FB_Client,"isc_blob_info")
  fb_getsegment = GetFunction(#FB_Client,"isc_get_segment")
  fb_putsegment = GetFunction(#FB_Client,"isc_put_segment")
  fb_vaxinteger = GetFunction(#FB_Client,"isc_vax_integer")
  fb_dbinfo = GetFunction(#FB_Client,"isc_database_info")
Else
  MessageRequester("Error","Library not found",0)
  End
EndIf

Global NewList fbDB.fbDatabase()
Global NewList fbRS.fbRecordSet()
Global NewList fbFld.fbField()

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

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.l ResultbufferFindToken(*ResultbufferVector, token.i)
  i = 0 : lens = 0
  While PeekB(*ResultbufferVector+i) <> #isc_info_end
    If PeekB(*ResultbufferVector+i) = token 
      ProcedureReturn i+1
    EndIf
    lens = fb_vaxinteger(*ResultbufferVector+i+1, 2)
    i = i + lens + 3
  Wend
  ProcedureReturn -1
EndProcedure

Procedure.l ResultbufferGetValue(*ResultbufferVector, token.i)
  value = 0
  p = ResultbufferFindToken(*ResultbufferVector, token)
  If p = -1 
    ProcedureReturn -1
  EndIf
  lens = fb_vaxinteger(*ResultbufferVector+p, 2)
  If lens = 0 
    value = 0
  Else
    value = fb_vaxinteger(*ResultbufferVector+p + 2, lens)
  EndIf
  ProcedureReturn value
EndProcedure

Procedure.i ResultbufferGetCountValue(*ResultbufferVector,token.i) ; Specifically used on tokens like isc_info_insert_count and the like which return detailed counts per relation. We sum up the values.
  value = 0
  p = ResultbufferFindToken(*ResultbufferVector, token)
  If i = -1 
    ProcedureReturn  -1
  EndIf
  i = 0
  lens = fb_vaxinteger(*ResultbufferVector+p, 2) ;len is the number of bytes in the following array
  i = i + 3
  value = 0
  While lens > 0  ; Each array item is 6 bytes : 2 bytes for the relation_id which we skip, and 4 bytes for the count value which we sum up accross all tables.
      value = value + fb_vaxinteger(*ResultbufferVector+p+2, 4)
      i = i + 6
      lens = lens - 6
  Wend
  ProcedureReturn value
EndProcedure

Procedure.i Statistics(*dbHandle, *dbbinfo.DBINFOS)
  *TPB = AllocateMemory(5)
  PokeB(*TPB + 0,#isc_info_fetches)
  PokeB(*TPB + 1,#isc_info_marks)
  PokeB(*TPB + 2,#isc_info_reads)
  PokeB(*TPB + 3,#isc_info_writes)
  PokeB(*TPB + 4,#isc_info_end)
  *resbuffer = AllocateMemory(128)
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 5, *TPB, 128,  *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\Fetches = ResultbufferGetValue(*resbuffer, #isc_info_fetches)
  *dbbinfo\Marks = ResultbufferGetValue(*resbuffer, #isc_info_marks)
  *dbbinfo\Reads = ResultbufferGetValue(*resbuffer, #isc_info_reads)
  *dbbinfo\Writes = ResultbufferGetValue(*resbuffer, #isc_info_writes)
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure


Procedure.i Info(*dbHandle,*dbbinfo.DBINFOS)
  *TPB = AllocateMemory(10)
  PokeB(*TPB + 0,#isc_info_ods_version)
  PokeB(*TPB + 1,#isc_info_ods_minor_version)
  PokeB(*TPB + 2,#isc_info_page_size)
  PokeB(*TPB + 3,#isc_info_allocation)
  PokeB(*TPB + 4,#isc_info_num_buffers)
  PokeB(*TPB + 5,#isc_info_sweep_interval)
  PokeB(*TPB + 6,#isc_info_forced_writes)
  PokeB(*TPB + 7,#isc_info_no_reserve)
  PokeB(*TPB + 8,#isc_info_db_sql_dialect)
  PokeB(*TPB + 9,#isc_info_end)
  *resbuffer = AllocateMemory(256)       
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 10, *TPB, 256, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\ODSMajor = ResultbufferGetValue(*resbuffer, #isc_info_ods_version)
  *dbbinfo\ODSMinor = ResultbufferGetValue(*resbuffer, #isc_info_ods_minor_version)
  *dbbinfo\PageSizes = ResultbufferGetValue(*resbuffer, #isc_info_page_size)
  *dbbinfo\Pages = ResultbufferGetValue(*resbuffer, #isc_info_allocation)
  *dbbinfo\Buffers = ResultbufferGetValue(*resbuffer, #isc_info_num_buffers)
  *dbbinfo\Sweep = ResultbufferGetValue(*resbuffer, #isc_info_sweep_interval)
  *dbbinfo\Sync = ResultbufferGetValue(*resbuffer, #isc_info_forced_writes)
  *dbbinfo\Reserve = ResultbufferGetValue(*resbuffer, #isc_info_no_reserve)
  *dbbinfo\Dialect = ResultbufferGetValue(*resbuffer, #isc_info_db_sql_dialect)
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure

Procedure.i Counts(*dbHandle,*dbbinfo.DBINFOS)
  *TPB = AllocateMemory(6)
  PokeB(*TPB + 0,#isc_info_insert_count)
  PokeB(*TPB + 1,#isc_info_update_count)
  PokeB(*TPB + 2,#isc_info_delete_count)
  PokeB(*TPB + 3,#isc_info_read_idx_count)
  PokeB(*TPB + 4,#isc_info_read_seq_count)
  PokeB(*TPB + 5,#isc_info_end)
  *resbuffer = AllocateMemory(1024)       
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 6, *TPB, 1024, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *dbbinfo\Inserts = ResultbufferGetCountValue(*resbuffer, #isc_info_insert_count)
  *dbbinfo\Update = ResultbufferGetCountValue(*resbuffer, #isc_info_update_count)
  *dbbinfo\Deletes = ResultbufferGetCountValue(*resbuffer, #isc_info_delete_count)
  *dbbinfo\ReadIdx = ResultbufferGetCountValue(*resbuffer, #isc_info_read_idx_count)
  *dbbinfo\ReadSeq = ResultbufferGetCountValue(*resbuffer, #isc_info_read_seq_count)
  ProcedureReturn #True
EndProcedure

Procedure.s DBUsers(*dbHandle)
  *TPB = AllocateMemory(2)
  PokeB(*TPB + 0,#isc_info_user_names)
  PokeB(*TPB + 1,#isc_info_end)
  *resbuffer = AllocateMemory(8000)  
  lresult = fb_dbinfo(@sv.ISC_STATUS, *dbHandle, 2, *TPB, 8000, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn ""
  EndIf
  i = 0 : j = 0 : usrs.s = "|" : x.s = ""
  While PeekB(*resbuffer+i) = #isc_info_user_names
    i = i + 3   ;Get to the length byte(there are two undocumented bytes which we skip)
    lens.i = PeekB(*resbuffer+i) 
    i = i + 1   ;Get to the first char of username
    If lens <> 0 
      x = ""
      For k = i To i + (lens-1)
        x = x + Chr(PeekB(*resbuffer+k)) 
      Next k
      usrs = usrs + x + "|"
      j = j + 1
    EndIf
    i = i + lens ;Skip username
  Wend
  FreeMemory(*resbuffer)
  ProcedureReturn usrs
EndProcedure

Procedure.i InfoBlob(*blobi.blobInfos)
  *TPB = AllocateMemory(4)
  PokeB(*TPB + 0,#isc_info_blob_total_length)
  PokeB(*TPB + 1,#isc_info_blob_max_segment)
  PokeB(*TPB + 2,#isc_info_blob_num_segments)
  PokeB(*TPB + 3,#isc_info_blob_type)
  *resbuffer = AllocateMemory(128)
  lresult = fb_infoblob(@sv.ISC_STATUS, @*blobi\BlobHandle, 4, *TPB, 128, *resbuffer)
  FreeMemory(*TPB)
  If lresult <> 0 
    FreeMemory(*resbuffer)
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\Sizes = ResultbufferGetValue(*resbuffer, #isc_info_blob_total_length)
  *blobi\Largest = ResultbufferGetValue(*resbuffer, #isc_info_blob_max_segment)
  *blobi\Segments = ResultbufferGetValue(*resbuffer, #isc_info_blob_num_segments)
  *blobi\Blobtype = ResultbufferGetValue(*resbuffer, #isc_info_blob_type) 
  FreeMemory(*resbuffer)
  ProcedureReturn #True
EndProcedure

Procedure CloseBlob(*blobhandle, writeMode.i)
  If *blobhandle <> 0 
    If writeMode = #False
      dum = fb_closeblob(@sv.ISC_STATUS, *blobhandle)
    Else
      dum = fb_cancelblob(@sv.ISC_STATUS, *blobhandle)
    EndIf
  EndIf
  If dum <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure CancelBlob(*blobhandle)
  dum = fb_cancelblob(@sv.ISC_STATUS, *blobhandle)
  If dum <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure.i CreateBlob(*blobi.blobInfos)
  lresult = fb_createblob(@sv.ISC_STATUS,@*blobi\DatabaseID, @*blobi\TransactionID,@*blobi\BlobHandle,@*blobi\BlobID, 0, 0)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #True
  ProcedureReturn #True
EndProcedure

Procedure.i OpenBlob(*blobi.blobInfos)
  lresult = fb_openblob(@sv.ISC_STATUS, @*blobi\DatabaseID, @*blobi\TransactionID, @*blobi\BlobHandle, @*blobi\BlobID, 0, 0)
  If lresult <> 0
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #False
  lresult = InfoBlob(*blobi.blobInfos)
  If lresult = #True And *blobi\Sizes > 0
    *blobi\BytesToRW = *blobi\Sizes / *blobi\Segments
  EndIf
  ProcedureReturn #True
EndProcedure

Procedure.i ReadBlob(*blobi.blobInfos, *buffer)
  If *blobi\Sizes > (64*1024-1)
      fb_LastErrorMessage = "ReadBlob sizes too large"
      ProcedureReturn -1
  EndIf
  lresult = fb_getsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\BytesRW, @*blobi\BytesToRW, *buffer)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn 0
  EndIf
  If lresult <> #isc_segment And (lresult <> 0)
      fb_LastErrorMessage = "Blob - Read status isc_get_segment failed."
      ProcedureReturn -1
  EndIf
  ProcedureReturn *blobi\BytesRW
EndProcedure

Procedure.i WriteBlob(*blobi.blobInfos, *buffer)
  If *blobi\Sizes > (64*1024-1)
      fb_LastErrorMessage = "WriteBlob sizes too large"
      ProcedureReturn #False
  EndIf
  lresult = fb_putsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\Sizes, *buffer)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  ProcedureReturn #True
EndProcedure
  
Procedure.i SaveBlob(*blobi.blobInfos, *datas)
  lresult = fb_createblob(@sv.ISC_STATUS,@*blobi\DatabaseID, @*blobi\TransactionID,@*blobi\BlobHandle,@*blobi\BlobID, 0, 0)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  *blobi\WriteMode = #True
  poss = 0
  While *blobi\BytesRW <> 0
      If *blobi\BytesRW < 32*1024-1
        blklen = *blobi\BytesRW
      Else
        blklen = 32*1024-1
      EndIf
      lresult = fb_putsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, blklen, *datas + poss)
      If lresult <> 0 
        xfb_InterpretDatabaseError(@sv)
        ProcedureReturn #False
      EndIf
      poss = poss + blklen
      *blobi\BytesRW = *blobi\BytesRW - blklen
  Wend
  lresult = CloseBlob(@*blobi\BlobHandle, *blobi\WriteMode)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  blobhandle = 0
  ProcedureReturn #True
EndProcedure

Procedure.i LoadBlob(*blobi.blobInfos, *datas)
  lresult = OpenBlob(*blobi.blobInfos)
  If lresult <> 0 
    fb_LastErrorMessage = "LoadBlob OpenBlob failed."
    ProcedureReturn #False
  EndIf
  mWriteMode = #False
  blklen = 32*1024-1
  datas = AllocateMemory(blklen)
  sizes = 0
  poss = 0
  Repeat
    lresult = fb_getsegment(@sv.ISC_STATUS, @*blobi\BlobHandle, @*blobi\BytesRW, blklen, *datas + poss)
      If lresult = #isc_segstr_eof 
          Break ;  End of blob
      EndIf
      If lresult <> #isc_segment And lresult <> 0
          fb_LastErrorMessage = "LoadBlob isc_get_segment failed."
          ProcedureReturn #False
      EndIf
      poss = poss + bytesread
      sizes = sizes + bytesread
;;;;;;;;;;;;;;;      ReDim datas(ArraySize(datas()) + sizes + blklen)
  Until 1
  ReAllocateMemory(*datas, sizes)
  lresult = CloseBlob(@*blobi\BlobHandle, *blobi\WriteMode)
  If lresult <> 0 
    xfb_InterpretDatabaseError(@sv)
    ProcedureReturn #False
  EndIf
  blobhandle = 0
  ProcedureReturn #True
EndProcedure

Procedure.s xfb_decodeDate(*ISC_DATE.q, *tm_date.tm)
  fb_decodedate(*ISC_DATE, *tm_date)
  *tm_date\tm_mon = *tm_date\tm_mon + 1
  *tm_date\tm_year = *tm_date\tm_year + 1900
  ProcedureReturn Str(*tm_date\tm_mon) + "-" + Str(*tm_date\tm_mday)+ "-" + Str(*tm_date\tm_year)
EndProcedure

Procedure.s xfb_decodeTime(*ISC_TIME.q, *tm_date.tm)
  fb_decodetime(*ISC_TIME, *tm_date)
  ProcedureReturn Str(*tm_date\tm_hour) + ":" + Str(*tm_date\tm_min) + ":" + Str(*tm_date\tm_sec) 
EndProcedure

Procedure.s xfb_decodeTimestamp(*ISC_TIMESTAMP.q, *tm_date.tm)
  fb_decodetimestamp(*ISC_TIMESTAMP, *tm_date)
  *tm_date\tm_mon = *tm_date\tm_mon + 1
  *tm_date\tm_year = *tm_date\tm_year + 1900
  ProcedureReturn Str(*tm_date\tm_mon) + "-" + Str(*tm_date\tm_mday)+ "-" + Str(*tm_date\tm_year) + " " + Str(*tm_date\tm_hour) + ":" + Str(*tm_date\tm_min) + ":" + Str(*tm_date\tm_sec)
EndProcedure

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.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+1)
      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_Ascii)
  lAlias.w = StringByteLength(DatabaseAlias,dbEncoding)
  *dbAlias = AllocateMemory(lAlias+1)
  PokeS(*dbAlias,DatabaseAlias,lAlias,dbEncoding)
  sParam.s = Chr(#isc_dpb_version1)
  lUN.w = StringByteLength(Username,dbEncoding)
  If lUN > 0
    sParam = sParam + Chr(#isc_dpb_user_name) + Chr(lUN) + Username
  EndIf
  lPWD.w = StringByteLength(Password,dbEncoding)
  If lPWD > 0
    sParam = sParam + Chr(#isc_dpb_password) + Chr(lPWD) + Password
  EndIf
  lUN = StringByteLength(sParam,dbEncoding)
  *dbParam = AllocateMemory(lUN+1)
  PokeS(*dbParam,sParam,lUN,dbEncoding)
  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 = ListSize(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()) : i = 0
  While NextElement(fbRS())
    x = fbRS()\FieldCount
    y = fbRS()\QueryID
    z = fbRS()\BufferAddress

    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
    i = i +1
  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


Procedure.i fb_GetRecordset(RecordsetID)
  ResetList(fbRS())
  i=0
  While NextElement(fbRS())
    If fbRS()\RecordsetID = RecordsetID
      ProcedureReturn i
    EndIf
    i = i +1
  Wend
  fb_LastErrorMessage = "fb_GetRecordset() - Invalid Recordset ID"
  ProcedureReturn -1 
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)
  tm_date.tm
  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
        qSize.q = PeekQ(fbFld()\BufferAddress)
        xfb_decodeTime(@qSize, @tm_date)
        sText.s = Str(iSize)
      Case #SQL_TYPE_DATE, #SQL_TYPE_DATE + 1, #SQL_DATE, #SQL_DATE + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = xfb_decodeDate(@qSize, @tm_date)
      Case #SQL_TIMESTAMP, #SQL_TIMESTAMP + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        sText.s = xfb_decodeTimestamp(@qSize, @tm_date)
      ;- haven't done blobs or arrays yet, this will just return the ID     
      Case #SQL_BLOB, #SQL_BLOB + 1
        qSize.q = PeekQ(fbFld()\BufferAddress)
        If qSize <= 0
          sText.s = "" : ProcedureReturn sText
        EndIf
        bi.blobInfos\BlobID = qSize
        i.i = fb_GetRecordset(RecordsetID)
        SelectElement(fbRS(), Position)
        bi\DatabaseID = fbRS()\DatabaseID
        bi\TransactionID = fbRS()\TransactionID
        bi\WriteMode = 0
        OpenBlob(@bi)
        buffer.s = Space(90)
        ReadBlob(@bi, @buffer)
        CloseBlob(@bi\BlobHandle, bi\WriteMode)
        sText.s = buffer        
      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

Structure SchemaForignKeysList
  CONSTRAINT_NAME.s
  TABLE_NAME.s
  COLUMN_NAME.s
  REFERENCED_TABLE_NAME.s
  REFERENCED_COLUMN_NAME.s
  ORDINAL_POSITION.i
EndStructure
Structure SchemaPrimaryKeyList
  TABLE_NAME.s
  COLUMN_NAME.s
  ORDINAL_POSITION.i
  PK_NAME.s
EndStructure
Structure SchemaGenerators
  GENERATOR_NAME.s
  GENERATOR_ID.i
  SYSTEM_FLAG.i
  DESCRIPTION.s
EndStructure
Structure SchemaIndex 
  CONSTRAINT_NAME.s
  TABLE_NAME.s
  COLUMN_NAME.s
  ORDINAL_POSITION.i
  INDEX_NAME.s
EndStructure
Structure SchemaFields
  FIELD_NAME.s
  FIELD_DESCRIPTION.s
  FIELD_DEFAULT_VALUE.s
  FIELD_NOT_NULL_CONSTRAINT.i
  FIELD_LENGTH.l
  FIELD_PRECISION.i
  FIELD_SCALE.l
  FIELD_TYPE.s
  FIELD_SUBTYPE.i
  FIELD_COLLATION.s
  FIELD_CHARSET.s
EndStructure
Structure SchemaTriggers
  TRIGGER_NAME.s
  RELATION_NAME.s
  FIELDNAME.s
  TRIGGER_SEQUENCE.i
  TRIGGER_TYPE.i
  DESCRIPTION.s
  TRIGGER_INACTIVE.i
  SYSTEM_FLAG.i
  FLAGS.i
  VALID_BLR.i
EndStructure

Procedure.i TableList(db, lTransID, List tables.s()) 
  Protected sql.s = "SELECT DISTINCT RDB$RELATION_NAME FROM RDB$RELATION_FIELDS WHERE RDB$SYSTEM_FLAG=0 AND RDB$VIEW_CONTEXT IS NULL";
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  Protected c.i
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  While fb_NextDatabaseRow(iRecordSet) 
    For c = 1 To iColCount
      If fb_DatabaseColumnIsNull(iRecordset,c)
      Else
        AddElement(tables())
        tables() = RTrim(fb_GetDatabaseString(iRecordset,c))
      EndIf
    Next
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(tables()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i ViewList(db, lTransID, List views.s()) 
  Protected sql.s = "SELECT DISTINCT RDB$VIEW_NAME FROM RDB$VIEW_RELATIONS";
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  Protected c.i
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  While fb_NextDatabaseRow(iRecordSet) 
    For c = 1 To iColCount
      If fb_DatabaseColumnIsNull(iRecordset,c)
      Else
        AddElement(views())
        views() = RTrim(fb_GetDatabaseString(iRecordset,c))
      EndIf
    Next
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(views()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i IndecesList(db, lTransID, List indeces.s(), forTable.s)
  Protected sql.s = "SELECT RDB$INDEX_NAME FROM RDB$INDICES WHERE RDB$RELATION_NAME = '" + UCase(forTable) + "' AND RDB$UNIQUE_FLAG IS NULL AND RDB$FOREIGN_KEY IS NULL";
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  While fb_NextDatabaseRow(iRecordSet)
    For c = 1 To iColCount
      If fb_DatabaseColumnIsNull(iRecordset,c)
      Else
        AddElement(indeces())
        indeces() = RTrim(fb_GetDatabaseString(iRecordset,c))
      EndIf
    Next
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(indeces()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i ConstraintsList(db, lTransID, List Constraints.s(), forTable.s)
  Protected sql.s = "SELECT RDB$INDEX_NAME FROM RDB$INDICES WHERE RDB$RELATION_NAME = '" + UCase(forTable) + "' AND (RDB$UNIQUE_FLAG IS NOT NULL OR RDB$FOREIGN_KEY IS NOT NULL)";
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    For c = 1 To iColCount
      If fb_DatabaseColumnIsNull(iRecordset,c)
      Else
        AddElement(Constraints())
        tmp = RTrim(fb_GetDatabaseString(iRecordset,c))        
        Constraints() = RTrim(fb_GetDatabaseString(iRecordset,c))
      EndIf
    Next
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(Constraints()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i PrimarykeyList(db, lTransID, List PrimaryKeys.SchemaPrimaryKeyList())
  Protected sql.s = "SELECT rel.rdb$relation_name As TABLE_NAME, seg.rdb$field_name As COLUMN_NAME, "
  sql = sql + "seg.rdb$field_position As ORDINAL_POSITION, rel.rdb$constraint_name As PK_NAME FROM "
  sql = sql + "rdb$relation_constraints rel left join rdb$indices idx ON rel.rdb$index_name = idx.rdb$index_name "
  sql = sql + "left join rdb$index_segments seg ON idx.rdb$index_name = seg.rdb$index_name where "
  sql = sql + "rel.rdb$constraint_type = 'PRIMARY KEY' ORDER BY rel.rdb$relation_name, rel.rdb$constraint_name, seg.rdb$field_position"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(PrimaryKeys())
    PrimaryKeys()\TABLE_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    PrimaryKeys()\COLUMN_NAME = RTrim(fb_GetDatabaseString(iRecordset,2))
    PrimaryKeys()\ORDINAL_POSITION = Val(RTrim(fb_GetDatabaseString(iRecordset,3)))
    PrimaryKeys()\PK_NAME = RTrim(fb_GetDatabaseString(iRecordset,4))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(PrimaryKeys()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i PrimarykeyByTableList(db, lTransID, List PrimaryKeys.SchemaPrimaryKeyList(), forTable.s)
  Protected sql.s = "SELECT rel.rdb$relation_name As TABLE_NAME, seg.rdb$field_name As COLUMN_NAME, "
  sql = sql + "seg.rdb$field_position As ORDINAL_POSITION, rel.rdb$constraint_name As PK_NAME FROM "
  sql = sql + "rdb$relation_constraints rel left join rdb$indices idx ON rel.rdb$index_name = idx.rdb$index_name "
  sql = sql + "left join rdb$index_segments seg ON idx.rdb$index_name = seg.rdb$index_name where "
  sql = sql + "rel.rdb$constraint_type = 'PRIMARY KEY' "
  sql = sql + "And rel.rdb$relation_name = '" + UCase(forTable)
  sql = sql + "' ORDER BY rel.rdb$relation_name, rel.rdb$constraint_name, seg.rdb$field_position"  
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(PrimaryKeys())
    PrimaryKeys()\TABLE_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    PrimaryKeys()\COLUMN_NAME = RTrim(fb_GetDatabaseString(iRecordset,2))
    PrimaryKeys()\ORDINAL_POSITION = Val(RTrim(fb_GetDatabaseString(iRecordset,3)))
    PrimaryKeys()\PK_NAME = RTrim(fb_GetDatabaseString(iRecordset,4))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(PrimaryKeys()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i ForeignKeysColumnList(db, lTransID, List ForignKeys.SchemaForignKeysList())
  Protected sql.s = "SELECT co.rdb$constraint_name As CONSTRAINT_NAME,co.rdb$relation_name As TABLE_NAME,"
  sql = sql + "coidxseg.rdb$field_name As COLUMN_NAME,refidx.rdb$relation_name As REFERENCED_TABLE_NAME,"
  sql = sql + "refidxseg.rdb$field_name As REFERENCED_COLUMN_NAME,coidxseg.rdb$field_position As ORDINAL_POSITION "
  sql = sql + "FROM rdb$relation_constraints co,rdb$ref_constraints ref,rdb$indices tempidx,rdb$indices refidx,"
  sql = sql + "rdb$index_segments coidxseg,rdb$index_segments refidxseg WHERE co.rdb$constraint_name = ref.rdb$constraint_name And "
  sql = sql + "co.rdb$constraint_type = 'FOREIGN KEY' And co.rdb$index_name = tempidx.rdb$index_name And "
  sql = sql + "co.rdb$index_name = coidxseg.rdb$index_name And refidx.rdb$index_name = tempidx.rdb$foreign_key And "
  sql = sql + "refidxseg.rdb$index_name = refidx.rdb$index_name And coidxseg.rdb$field_position = refidxseg.rdb$field_position"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(ForignKeys())
    ForignKeys()\CONSTRAINT_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    ForignKeys()\TABLE_NAME = RTrim(fb_GetDatabaseString(iRecordset,2))
    ForignKeys()\COLUMN_NAME = RTrim(fb_GetDatabaseString(iRecordset,3))
    ForignKeys()\REFERENCED_TABLE_NAME = RTrim(fb_GetDatabaseString(iRecordset,4))
    ForignKeys()\REFERENCED_COLUMN_NAME = RTrim(fb_GetDatabaseString(iRecordset,5))
    ForignKeys()\ORDINAL_POSITION = Val(RTrim(fb_GetDatabaseString(iRecordset,6)))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(ForignKeys()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i GeneratorsList(db, lTransID, List Generators.SchemaGenerators())
  Protected sql.s = "SELECT * FROM RDB$GENERATORS WHERE RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG = 0"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(Generators())
    Generators()\GENERATOR_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    Generators()\GENERATOR_ID = Val(RTrim(fb_GetDatabaseString(iRecordset,2)))
    Generators()\SYSTEM_FLAG = Val(RTrim(fb_GetDatabaseString(iRecordset,3)))
    Generators()\DESCRIPTION = RTrim(fb_GetDatabaseString(iRecordset,4))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(Generators()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i FieldnamesList(db, lTransID, List Fields.SchemaFields(), forTable.s)
  Protected sql.s = "SELECT r.RDB$FIELD_NAME AS field_name,"
  sql = sql + "r.RDB$DESCRIPTION AS field_description,r.RDB$DEFAULT_VALUE As field_default_value,r.RDB$NULL_FLAG As field_not_null_constraint,"
  sql = sql + "f.RDB$FIELD_LENGTH As field_length,f.RDB$FIELD_PRECISION As field_precision,f.RDB$FIELD_SCALE AS field_scale,"
  sql = sql + "Case f.RDB$FIELD_TYPE "
  sql = sql + "WHEN 261 THEN 'BLOB' "
  sql = sql + "WHEN 14 THEN 'CHAR' "
  sql = sql + "WHEN 40 THEN 'CSTRING' "
  sql = sql + "WHEN 11 THEN 'D_FLOAT' "
  sql = sql + "WHEN 27 THEN 'DOUBLE' "
  sql = sql + "WHEN 10 THEN 'FLOAT' "
  sql = sql + "WHEN 16 THEN 'INT64' "
  sql = sql + "WHEN 8 THEN 'INTEGER' "
  sql = sql + "WHEN 9 THEN 'QUAD' "
  sql = sql + "WHEN 7 THEN 'SMALLINT' "
  sql = sql + "WHEN 12 THEN 'DATE' "
  sql = sql + "WHEN 13 THEN 'TIME' "
  sql = sql + "WHEN 35 THEN 'TIMESTAMP' "
  sql = sql + "WHEN 37 THEN 'VARCHAR' "
  sql = sql + "Else 'UNKNOWN' "
  sql = sql + "End As field_type,f.RDB$FIELD_SUB_TYPE AS field_subtype,coll.RDB$COLLATION_NAME AS field_collation,"
  sql = sql + "cset.RDB$CHARACTER_SET_NAME AS field_charset FROM RDB$RELATION_FIELDS r LEFT JOIN RDB$FIELDS f ON r.RDB$FIELD_SOURCE = f.RDB$FIELD_NAME "
  sql = sql + "LEFT JOIN RDB$COLLATIONS coll ON r.RDB$COLLATION_ID = coll.RDB$COLLATION_ID AND f.RDB$CHARACTER_SET_ID = coll.RDB$CHARACTER_SET_ID "
  sql = sql + "LEFT JOIN RDB$CHARACTER_SETS cset ON f.RDB$CHARACTER_SET_ID = cset.RDB$CHARACTER_SET_ID "
  sql = sql + "WHERE r.RDB$RELATION_NAME = '" + UCase(forTable) + "' ORDER BY r.RDB$FIELD_POSITION;"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(Fields())
    Fields()\FIELD_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    Fields()\FIELD_DESCRIPTION = RTrim(fb_GetDatabaseString(iRecordset,2))
    Fields()\FIELD_DEFAULT_VALUE = RTrim(fb_GetDatabaseString(iRecordset,3))
    Fields()\FIELD_NOT_NULL_CONSTRAINT = Val(fb_GetDatabaseString(iRecordset,4))
    Fields()\FIELD_LENGTH = Val(fb_GetDatabaseString(iRecordset,5))
    Fields()\FIELD_PRECISION = Val(RTrim(fb_GetDatabaseString(iRecordset,6)))
    Fields()\FIELD_SCALE = Val(RTrim(fb_GetDatabaseString(iRecordset,7)))
    Fields()\FIELD_TYPE = RTrim(fb_GetDatabaseString(iRecordset,8))
    Fields()\FIELD_SUBTYPE = Val(fb_GetDatabaseString(iRecordset,9))
    Fields()\FIELD_COLLATION = RTrim(fb_GetDatabaseString(iRecordset,10))
    Fields()\FIELD_CHARSET = RTrim(fb_GetDatabaseString(iRecordset,11))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(Fields()) 
  ProcedureReturn iRecordCount
EndProcedure
Procedure.i TriggerList(db, lTransID, List Triggers.SchemaTriggers())
  Protected sql.s = "SELECT * FROM RDB$TRIGGERS WHERE RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG = 0"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(Triggers())
    Triggers()\TRIGGER_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    Triggers()\RELATION_NAME = RTrim(fb_GetDatabaseString(iRecordset,2))
    Triggers()\TRIGGER_SEQUENCE = Val(RTrim(fb_GetDatabaseString(iRecordset,3)))
    Triggers()\TRIGGER_TYPE = Val(fb_GetDatabaseString(iRecordset,4))
    Triggers()\FIELDNAME = RTrim(fb_GetDatabaseString(iRecordset,5))
    Triggers()\DESCRIPTION = RTrim(fb_GetDatabaseString(iRecordset,6))
    Triggers()\TRIGGER_INACTIVE = Val(RTrim(fb_GetDatabaseString(iRecordset,7)))
    Triggers()\SYSTEM_FLAG = Val(RTrim(fb_GetDatabaseString(iRecordset,8)))
    Triggers()\FLAGS = Val(fb_GetDatabaseString(iRecordset,9))
    Triggers()\VALID_BLR = Val(RTrim(fb_GetDatabaseString(iRecordset,10)))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(Triggers()) 
  ProcedureReturn iRecordCount
EndProcedure

Procedure.i TriggerTableList(db, lTransID, List Triggers.SchemaTriggers(), forTable.s)
  Protected sql.s = "SELECT * FROM RDB$TRIGGERS WHERE (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG = 0) AND RDB$RELATION_NAME= '" + UCase(forTable) + "'"
  Protected iRecordSet = fb_SQLSelect(db, lTransID, sql)
  Protected iRecordCount.i = 0
  Protected iColCount = fb_DatabaseColumns(iRecordset)
  If iColCount < 0 : ProcedureReturn iColCount : EndIf
  Protected c.i
  Protected tmp.s
  While fb_NextDatabaseRow(iRecordSet)
    AddElement(Triggers())
    Triggers()\TRIGGER_NAME = RTrim(fb_GetDatabaseString(iRecordset,1))
    Triggers()\RELATION_NAME = RTrim(fb_GetDatabaseString(iRecordset,2))
    Triggers()\TRIGGER_SEQUENCE = Val(RTrim(fb_GetDatabaseString(iRecordset,3)))
    Triggers()\TRIGGER_TYPE = Val(fb_GetDatabaseString(iRecordset,4))
    Triggers()\FIELDNAME = RTrim(fb_GetDatabaseString(iRecordset,5))
    Triggers()\DESCRIPTION = RTrim(fb_GetDatabaseString(iRecordset,6))
    Triggers()\TRIGGER_INACTIVE = Val(RTrim(fb_GetDatabaseString(iRecordset,7)))
    Triggers()\SYSTEM_FLAG = Val(RTrim(fb_GetDatabaseString(iRecordset,8)))
    Triggers()\FLAGS = Val(fb_GetDatabaseString(iRecordset,9))
    Triggers()\VALID_BLR = Val(RTrim(fb_GetDatabaseString(iRecordset,10)))
    iRecordCount = iRecordCount + 1
  Wend
  fb_CloseRecordset(iRecordset)
  ResetList(Triggers()) 
  ProcedureReturn iRecordCount
EndProcedure

siesit · Post by **siesit** » Thu Nov 11, 2010 9:47 pm

I will test later
thankee

PureBasic Forums - English

Interbase & Firebird : Wrapper Problem

Re: Interbase & Firebird : Wrapper Problem

Re: Interbase & Firebird : Wrapper Problem

Re: Interbase & Firebird : Wrapper Problem

Re: Interbase & Firebird : Wrapper Problem