fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
760112e3c536cac524aa98f97fb8a613a9f9de0b
harbour-core/contrib/hbfbird/tfirebrd.prg
Viktor Szakats 760112e3c5 2017-09-12 15:13 UTC Viktor Szakats (vszakats users.noreply.github.com) 
* bin/check.hb
  * config/*/*.mk
  * contrib/gtwvg/wvgwing.c
  * contrib/hbcomm/comm.prg
  * contrib/hbfbird/tfirebrd.prg
  * contrib/hbfimage/fi_wrp.c
  * contrib/hbformat/hbfmtcls.prg
  * contrib/hbformat/utils/hbformat.prg
  * contrib/hbhttpd/core.prg
  * contrib/hbnetio/utils/hbnetio/hbnetio.prg
  * contrib/hbnetio/utils/hbnetio/netiomgm.hb
  * contrib/hbsqlit3/hdbc.prg
  * contrib/hbwin/win_bmp.c
  * contrib/xhb/htmutil.prg
  * contrib/xhb/thtm.prg
  * contrib/xhb/xhbarr.c
  * contrib/xhb/xhbtedit.prg
  * ChangeLog.txt
  * debian/control
  * debian/copyright
  * doc/*.txt
  * LICENSE.txt
  * package/harbour.spec
  * README.md
  * src/compiler/hbusage.c
  * src/pp/hbpp.c
  * src/rtl/memoedit.prg
  * src/rtl/teditor.prg
  * src/rtl/tget.prg
  * src/rtl/version.c
  * utils/hbi18n/hbi18n.prg
  * utils/hbmk2/hbmk2.prg
  * utils/hbmk2/po/hbmk2.hu.po
  * utils/hbtest/hbtest.prg
    * sync with 3.4 fork (no change in functionality)
      CC3 -> CC4 license, copyright banners, some strings, minor
      code changes, doc folder, TOFIX -> FIXME
2017-09-12 15:15:14 +00:00

1087 lines
24 KiB
Plaintext
Raw Blame History

/*
* Firebird RDBMS low-level (client API) interface code.
*
* Copyright 2003 Rodrigo Moreno rodrigo_moreno@yahoo.com
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; see the file LICENSE.txt. If not, write to
* the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
* Boston, MA 02110-1301 USA (or visit https://www.gnu.org/licenses/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbclass.ch"
#define SQL_TEXT 452
#define SQL_VARYING 448
#define SQL_SHORT 500
#define SQL_LONG 496
#define SQL_FLOAT 482
#define SQL_DOUBLE 480
#define SQL_D_FLOAT 530
#define SQL_TIMESTAMP 510
#define SQL_BLOB 520
#define SQL_ARRAY 540
#define SQL_QUAD 550
#define SQL_TYPE_TIME 560
#define SQL_TYPE_DATE 570
#define SQL_INT64 580
#define SQL_DATE SQL_TIMESTAMP
CREATE CLASS TFbServer
VAR db
VAR trans
VAR StartedTrans
VAR nError
VAR lError
VAR dialect
METHOD New( cServer, cUser, cPassword, nDialect )
METHOD Destroy() INLINE FBClose( ::db )
METHOD Close() INLINE FBClose( ::db )
METHOD TableExists( cTable )
METHOD ListTables()
METHOD TableStruct( cTable )
METHOD StartTransaction()
METHOD Commit()
METHOD Rollback()
METHOD Execute( cQuery )
METHOD Query( cQuery )
METHOD Update( oRow, cWhere )
METHOD Delete( oRow, cWhere )
METHOD Append( oRow )
METHOD NetErr() INLINE ::lError
METHOD Error() INLINE FBError( ::nError )
METHOD ErrorNo() INLINE ::nError
ENDCLASS
METHOD New( cServer, cUser, cPassword, nDialect ) CLASS TFbServer
hb_default( @nDialect, 1 )
::lError := .F.
::nError := 0
::StartedTrans := .F.
::Dialect := nDialect
::db := FBConnect( cServer, cUser, cPassword )
IF HB_ISNUMERIC( ::db )
::lError := .T.
::nError := ::db
ENDIF
RETURN self
METHOD StartTransaction() CLASS TFbServer
LOCAL result := .F.
::trans := FBStartTransaction( ::db )
IF HB_ISNUMERIC( ::trans )
::lError := .T.
::nError := ::trans
ELSE
result := .T.
::lError := .F.
::lnError := 0
::StartedTrans := .T.
ENDIF
RETURN result
METHOD Rollback() CLASS TFbServer
LOCAL result := .F.
LOCAL n
IF ::StartedTrans
IF ( n := FBRollback( ::trans ) ) < 0
::lError := .T.
::nError := n
ELSE
::lError := .F.
::nError := 0
result := .T.
::StartedTrans := .F.
ENDIF
ENDIF
RETURN result
METHOD Commit() CLASS TFbServer
LOCAL result := .F.
LOCAL n
IF ::StartedTrans
IF ( n := FBCommit( ::trans ) ) < 0
::lError := .T.
::nError := n
ELSE
::lError := .F.
::nError := 0
result := .T.
::StartedTrans := .F.
ENDIF
ENDIF
RETURN result
METHOD Execute( cQuery ) CLASS TFbServer
LOCAL result
LOCAL n
cQuery := RemoveSpaces( cQuery )
IF ::StartedTrans
n := FBExecute( ::db, cQuery, ::dialect, ::trans )
ELSE
n := FBExecute( ::db, cQuery, ::dialect )
ENDIF
IF n < 0
::lError := .T.
::nError := n
result := .F.
ELSE
::lError := .F.
::nError := 0
result := .T.
ENDIF
RETURN result
METHOD Query( cQuery ) CLASS TFbServer
RETURN TFBQuery():New( ::db, cQuery, ::dialect )
METHOD TableExists( cTable ) CLASS TFbServer
LOCAL cQuery
LOCAL result := .F.
LOCAL qry
cQuery := 'select rdb$relation_name from rdb$relations where rdb$relation_name = "' + Upper( cTable ) + '"'
qry := FBQuery( ::db, cQuery, ::dialect )
IF HB_ISARRAY( qry )
result := ( FBFetch( qry ) == 0 )
FBFree( qry )
ENDIF
RETURN result
METHOD ListTables() CLASS TFbServer
LOCAL result := {}
LOCAL cQuery
LOCAL qry
cQuery := 'select rdb$relation_name '
cQuery += ' from rdb$relations '
cQuery += ' where rdb$relation_name not like "RDB$%" '
cQuery += ' and rdb$view_blr is null '
cQuery += ' order by 1 '
qry := FBQuery( ::db, RemoveSpaces( cQuery ), ::dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
AAdd( result, FBGetData( qry, 1 ) )
ENDDO
FBFree( qry )
ENDIF
RETURN result
METHOD TableStruct( cTable ) CLASS TFbServer
LOCAL result := {}
LOCAL cQuery, cType, nSize, cDomain, cField, nType, nDec
LOCAL qry
cQuery := 'select '
cQuery += ' a.rdb$field_name,'
cQuery += ' b.rdb$field_type,'
cQuery += ' b.rdb$field_length,'
cQuery += ' b.rdb$field_scale * -1,'
cQuery += ' a.rdb$field_source '
cQuery += 'from '
cQuery += ' rdb$relation_fields a, rdb$fields b '
cQuery += 'where '
cQuery += ' a.rdb$field_source = b.rdb$field_name '
cQuery += ' and a.rdb$relation_name = "' + Upper( ctable ) + '" '
cQuery += 'order by '
cQuery += ' a.rdb$field_position '
qry := FBQuery( ::db, RemoveSpaces( cQuery ), ::dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
cField := FBGetData( qry, 1 )
nType := Val( FBGetData( qry, 2 ) )
nSize := Val( FBGetData( qry, 3 ) )
nDec := Val( FBGetData( qry, 4 ) )
cDomain := FBGetData( qry, 5 )
SWITCH nType
CASE 7 // SMALLINT
IF "BOOL" $ cDomain
cType := "L"
nSize := 1
nDec := 0
ELSE
cType := "N"
nSize := 5
ENDIF
EXIT
CASE 8 // INTEGER
CASE 9
cType := "N"
nSize := 9
EXIT
CASE 10 // FLOAT
CASE 11
cType := "N"
nSize := 15
EXIT
CASE 12 // DATE
cType := "D"
nSize := 8
EXIT
CASE 13 // TIME
cType := "C"
nSize := 10
EXIT
CASE 14 // CHAR
cType := "C"
EXIT
CASE 16 // INT64
cType := "N"
nSize := 9
EXIT
CASE 27 // DOUBLE
cType := "N"
nSize := 15
EXIT
CASE 35 // TIMESTAMP
cType := "D"
nSize := 8
EXIT
CASE 37 // VARCHAR
CASE 40
cType := "C"
EXIT
CASE 261 // BLOB
cType := "M"
nSize := 10
EXIT
OTHERWISE
cType := "C"
nDec := 0
ENDSWITCH
AAdd( result, { cField, cType, nSize, nDec } )
ENDDO
FBFree( qry )
ENDIF
RETURN result
METHOD Delete( oRow, cWhere ) CLASS TFbServer
LOCAL result := .F.
LOCAL aKeys, i, nField, xField, cQuery, aTables
aTables := oRow:GetTables()
IF ! HB_ISNUMERIC( ::db ) .AND. Len( aTables ) == 1
// Cannot delete joined tables
IF cWhere == NIL
aKeys := oRow:GetKeyField()
cWhere := ""
FOR i := 1 TO Len( aKeys )
nField := oRow:FieldPos( aKeys[ i ] )
xField := oRow:FieldGet( nField )
cWhere += aKeys[ i ] + "=" + DataToSql( xField )
IF i != Len( aKeys )
cWhere += ","
ENDIF
NEXT
ENDIF
IF !( cWhere == "" )
cQuery := 'DELETE FROM ' + aTables[ 1 ] + ' WHERE ' + cWhere
result := ::Execute( cQuery )
ENDIF
ENDIF
RETURN result
METHOD Append( oRow ) CLASS TFbServer
LOCAL result := .F.
LOCAL cQuery, i, aTables
aTables := oRow:GetTables()
IF ! HB_ISNUMERIC( ::db ) .AND. Len( aTables ) == 1
// Can insert only one table, not in joined tables
cQuery := 'INSERT INTO ' + aTables[ 1 ] + '('
FOR i := 1 TO oRow:FCount()
IF oRow:Changed( i )
// Send only changed field
cQuery += oRow:FieldName( i ) + ","
ENDIF
NEXT
cQuery := Left( cQuery, Len( cQuery ) - 1 ) + ") VALUES ("
FOR i := 1 TO oRow:FCount()
IF oRow:Changed( i )
cQuery += DataToSql( oRow:FieldGet( i ) ) + ","
ENDIF
NEXT
cQuery := Left( cQuery, Len( cQuery ) - 1 ) + ")"
result := ::Execute( cQuery )
ENDIF
RETURN result
METHOD Update( oRow, cWhere ) CLASS TFbServer
LOCAL result := .F.
LOCAL aKeys, cQuery, i, nField, xField, aTables
aTables := oRow:GetTables()
IF ! HB_ISNUMERIC( ::db ) .AND. Len( aTables ) == 1
// Can't insert joined tables
IF cWhere == NIL
aKeys := oRow:GetKeyField()
cWhere := ""
FOR i := 1 TO Len( aKeys )
nField := oRow:FieldPos( aKeys[ i ] )
xField := oRow:FieldGet( nField )
cWhere += aKeys[ i ] + "=" + DataToSql( xField )
IF i != Len( aKeys )
cWhere += ", "
ENDIF
NEXT
ENDIF
cQuery := "UPDATE " + aTables[ 1 ] + " SET "
FOR i := 1 TO oRow:FCount()
IF oRow:Changed( i )
cQuery += oRow:FieldName( i ) + " = " + DataToSql( oRow:FieldGet( i ) ) + ","
ENDIF
NEXT
IF !( cWhere == "" )
cQuery := Left( cQuery, Len( cQuery ) - 1 ) + " WHERE " + cWhere
result := ::Execute( cQuery )
ENDIF
ENDIF
RETURN result
CREATE CLASS TFbQuery
VAR nError
VAR lError
VAR Dialect
VAR lBof
VAR lEof
VAR nRecno
VAR qry
VAR aStruct
VAR numcols
VAR closed
VAR db
VAR query
VAR aKeys
VAR aTables
METHOD New( nDB, cQuery, nDialect )
METHOD Destroy()
METHOD Close() INLINE ::Destroy()
METHOD Refresh()
METHOD Fetch()
METHOD Skip() INLINE ::Fetch()
METHOD Bof() INLINE ::lBof
METHOD Eof() INLINE ::lEof
METHOD RecNo() INLINE ::nRecno
METHOD NetErr() INLINE ::lError
METHOD Error() INLINE FBError( ::nError )
METHOD ErrorNo() INLINE ::nError
METHOD FCount() INLINE ::numcols
METHOD Struct()
METHOD FieldName( nField )
METHOD FieldPos( cField )
METHOD FieldLen( nField )
METHOD FieldDec( nField )
METHOD FieldType( nField )
METHOD FieldGet( nField )
METHOD GetRow()
METHOD GetBlankRow()
METHOD Blank() INLINE ::GetBlankRow()
METHOD GetKeyField()
ENDCLASS
METHOD New( nDB, cQuery, nDialect ) CLASS TFbQuery
::db := nDb
::query := RemoveSpaces( cQuery )
::dialect := nDialect
::closed := .T.
::aKeys := NIL
::Refresh()
RETURN self
METHOD Refresh() CLASS TFbQuery
LOCAL qry, result, i, aTable := {}
IF ! ::closed
::Destroy()
ENDIF
::lBof := .T.
::lEof := .F.
::nRecno := 0
::closed := .F.
::numcols := 0
::aStruct := {}
::nError := 0
::lError := .F.
result := .T.
qry := FBQuery( ::db, ::query, ::dialect )
IF HB_ISARRAY( qry )
::numcols := qry[ 4 ]
/* FIXME: This is faulty code. ::aStruct will become zero length, out of sync with ::numcols. */
::aStruct := StructConvert( qry[ 6 ], ::db, ::dialect )
::lError := .F.
::nError := 0
::qry := qry
/* Tables in query */
FOR i := 1 TO Len( ::aStruct )
IF hb_AScan( aTable, ::aStruct[ i ][ 5 ], , , .T. ) == 0
AAdd( aTable, ::aStruct[ i ][ 5 ] )
ENDIF
NEXT
::aTables := aTable
ELSE
::lError := .T.
::nError := qry
ENDIF
RETURN result
METHOD Destroy() CLASS TFbQuery
LOCAL result := .T.
LOCAL n
IF ! ::lError .AND. ( n := FBFree( ::qry ) ) < 0
::lError := .T.
::nError := n
ENDIF
::closed := .T.
RETURN result
METHOD Fetch() CLASS TFbQuery
LOCAL result := .F.
LOCAL fetch_stat
IF ! ::lError .AND. ! ::lEof
IF ! ::Closed
fetch_stat := FBFetch( ::qry )
::nRecno++
IF fetch_stat == 0
::lBof := .F.
result := .T.
ELSE
::lEof := .T.
ENDIF
ENDIF
ENDIF
RETURN result
METHOD Struct() CLASS TFbQuery
LOCAL result := {}
LOCAL i
IF ! ::lError
FOR i := 1 TO Len( ::aStruct )
AAdd( result, { ::aStruct[ i ][ 1 ], ::aStruct[ i ][ 2 ], ::aStruct[ i ][ 3 ], ::aStruct[ i ][ 4 ] } )
NEXT
ENDIF
RETURN result
METHOD FieldPos( cField ) CLASS TFbQuery
LOCAL result := 0
IF ! ::lError
result := AScan( ::aStruct, {| x | x[ 1 ] == RTrim( Upper( cField ) ) } )
ENDIF
RETURN result
METHOD FieldName( nField ) CLASS TFbQuery
LOCAL result
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 1 ]
ENDIF
RETURN result
METHOD FieldType( nField ) CLASS TFbQuery
LOCAL result
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 2 ]
ENDIF
RETURN result
METHOD FieldLen( nField ) CLASS TFbQuery
LOCAL result
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 3 ]
ENDIF
RETURN result
METHOD FieldDec( nField ) CLASS TFbQuery
LOCAL result
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 4 ]
ENDIF
RETURN result
METHOD FieldGet( nField ) CLASS TFbQuery
LOCAL result, aBlob, i, cType
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct ) .AND. ! ::closed
/* TODO: Convert to right data type */
result := FBGetData( ::qry, nField )
cType := ::aStruct[ nField ][ 2 ]
IF cType == "M"
/* Blob */
IF result != NIL
aBlob := FBGetBlob( ::db, result )
result := ""
FOR i := 1 TO Len( aBlob )
result += aBlob[ i ]
NEXT
// result := FBGetBlob( ::db, result )
ELSE
result := ""
ENDIF
ELSEIF cType == "N"
IF result != NIL
result := Val( result )
ELSE
result := 0
ENDIF
ELSEIF cType == "D"
IF result != NIL
result := hb_SToD( Left( result, 4 ) + SubStr( result, 5, 2 ) + SubStr( result, 7, 2 ) )
ELSE
result := hb_SToD()
ENDIF
ELSEIF cType == "L"
IF result != NIL
result := ( Val( result ) == 1 )
ELSE
result := .F.
ENDIF
ENDIF
ENDIF
RETURN result
METHOD Getrow() CLASS TFbQuery
LOCAL result
LOCAL aRow
LOCAL i
IF ! ::lError .AND. ! ::closed
aRow := Array( ::numcols )
FOR i := 1 TO ::numcols
aRow[ i ] := ::FieldGet( i )
NEXT
result := TFBRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables )
ENDIF
RETURN result
METHOD GetBlankRow() CLASS TFbQuery
LOCAL result
LOCAL aRow
LOCAL i
IF ! ::lError
aRow := Array( ::numcols )
FOR i := 1 TO ::numcols
SWITCH ::aStruct[ i ][ 2 ]
CASE "C"
CASE "M"
aRow[ i ] := ""
EXIT
CASE "N"
aRow[ i ] := 0
EXIT
CASE "L"
aRow[ i ] := .F.
EXIT
CASE "D"
aRow[ i ] := hb_SToD()
EXIT
ENDSWITCH
NEXT
result := TFBRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables )
ENDIF
RETURN result
METHOD GetKeyField() CLASS TFbQuery
IF ::aKeys == NIL
::aKeys := KeyField( ::aTables, ::db, ::dialect )
ENDIF
RETURN ::aKeys
CREATE CLASS TFbRow
VAR aRow
VAR aStruct
VAR aChanged
VAR aKeys
VAR db
VAR dialect
VAR aTables
METHOD New( row, struct, nDB, nDialect, aTable )
METHOD Changed( nField )
METHOD GetTables() INLINE ::aTables
METHOD FCount() INLINE Len( ::aRow )
METHOD FieldGet( nField )
METHOD FieldPut( nField, Value )
METHOD FieldName( nField )
METHOD FieldPos( cField )
METHOD FieldLen( nField )
METHOD FieldDec( nField )
METHOD FieldType( nField )
METHOD GetKeyField()
ENDCLASS
METHOD new( row, struct, nDb, nDialect, aTable ) CLASS TFbRow
::aRow := row
::aStruct := struct
::db := nDB
::dialect := nDialect
::aTables := aTable
::aChanged := Array( Len( row ) )
RETURN self
METHOD Changed( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aRow )
result := ( ::aChanged[ nField ] != NIL )
ENDIF
RETURN result
METHOD FieldGet( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aRow )
result := ::aRow[ nField ]
ENDIF
RETURN result
METHOD FieldPut( nField, Value ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aRow )
::aChanged[ nField ] := .T.
result := ::aRow[ nField ] := Value
ENDIF
RETURN result
METHOD FieldName( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 1 ]
ENDIF
RETURN result
METHOD FieldPos( cField ) CLASS TFbRow
RETURN AScan( ::aStruct, {| x | x[ 1 ] == RTrim( Upper( cField ) ) } )
METHOD FieldType( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 2 ]
ENDIF
RETURN result
METHOD FieldLen( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 3 ]
ENDIF
RETURN result
METHOD FieldDec( nField ) CLASS TFbRow
LOCAL result
IF nField >= 1 .AND. nField <= Len( ::aStruct )
result := ::aStruct[ nField ][ 4 ]
ENDIF
RETURN result
METHOD GetKeyField() CLASS TFbRow
IF ::aKeys == NIL
::aKeys := KeyField( ::aTables, ::db, ::dialect )
ENDIF
RETURN ::aKeys
STATIC FUNCTION KeyField( aTables, db, dialect )
LOCAL cTable, cQuery
LOCAL qry
LOCAL aKeys := {}
/* Check row, many tables exists in current query, so we must have only one table */
IF Len( aTables ) == 1
cTable := aTables[ 1 ]
cQuery := ' select '
cQuery += ' a.rdb$field_name '
cQuery += ' from '
cQuery += ' rdb$index_segments a, '
cQuery += ' rdb$relation_constraints b '
cQuery += ' where '
cQuery += ' a.rdb$index_name = b.rdb$index_name and '
cQuery += ' b.rdb$constraint_type = "PRIMARY KEY" and '
cQuery += ' b.rdb$relation_name = ' + DataToSql( cTable )
cQuery += ' order by '
cQuery += ' b.rdb$relation_name, '
cQuery += ' a.rdb$field_position '
qry := FBQuery( db, RemoveSpaces( cQuery ), dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
AAdd( aKeys, RTrim( FBGetData( qry, 1 ) ) )
ENDDO
FBFree( qry )
ENDIF
ENDIF
RETURN aKeys
STATIC FUNCTION DataToSql( xField )
SWITCH ValType( xField )
CASE "C"
RETURN '"' + StrTran( xField, '"', ' ' ) + '"'
CASE "D"
RETURN '"' + StrZero( Month( xField ), 2 ) + "/" + StrZero( Day( xField ), 2 ) + "/" + StrZero( Year( xField ), 4 ) + '"'
CASE "N"
RETURN Str( xField )
CASE "L"
RETURN iif( xField, "1", "0" )
ENDSWITCH
RETURN NIL
STATIC FUNCTION StructConvert( aStru, db, dialect )
LOCAL aNew := {}
LOCAL cField
LOCAL nType
LOCAL cType
LOCAL nSize
LOCAL nDec
LOCAL cTable
LOCAL cDomain
LOCAL i
LOCAL qry
LOCAL cQuery
LOCAL aDomains := {}
LOCAL nVal
LOCAL xTables := ""
LOCAL xFields := ""
/* create table list and field list */
FOR i := 1 TO Len( aStru )
xtables += DataToSql( aStru[ i ][ 5 ] )
xfields += DataToSql( aStru[ i ][ 1 ] )
IF i != Len( aStru )
xtables += ","
xfields += ","
ENDIF
NEXT
/* Look for domains */
cQuery := 'select rdb$relation_name, rdb$field_name, rdb$field_source '
cQuery += ' from rdb$relation_fields '
cQuery += ' where rdb$field_name not like "RDB$%" '
cQuery += ' and rdb$relation_name in (' + xtables + ')'
cQuery += ' and rdb$field_name in (' + xfields + ')'
qry := FBQuery( db, RemoveSpaces( cQuery ), dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
AAdd( aDomains, { ;
iif( FBGetData( qry, 1 ) == NIL, "", FBGetData( qry, 1 ) ), ;
iif( FBGetData( qry, 2 ) == NIL, "", FBGetData( qry, 2 ) ), ;
iif( FBGetData( qry, 3 ) == NIL, "", FBGetData( qry, 3 ) ) } )
ENDDO
FBFree( qry )
FOR i := 1 TO Len( aStru )
cField := RTrim( aStru[ i ][ 7 ] )
nType := aStru[ i ][ 2 ]
nSize := aStru[ i ][ 3 ]
nDec := aStru[ i ][ 4 ] * -1
cTable := RTrim( aStru[ i ][ 5 ] )
nVal := AScan( aDomains, {| x | RTrim( x[ 1 ] ) == cTable .AND. RTrim( x[ 2 ] ) == cField } )
IF nVal != 0
cDomain := aDomains[ nVal, 3 ]
ELSE
cDomain := ""
ENDIF
SWITCH nType
CASE SQL_TEXT
cType := "C"
EXIT
CASE SQL_VARYING
cType := "C"
EXIT
CASE SQL_SHORT
/* Firebird doesn't have boolean field, so if you define domain with BOOL then i will consider logical, ex:
create domain boolean_field as smallint default 0 not null check (value in (0,1)) */
IF "BOOL" $ cDomain
cType := "L"
nSize := 1
nDec := 0
ELSE
cType := "N"
nSize := 5
ENDIF
EXIT
CASE SQL_LONG
cType := "N"
nSize := 9
EXIT
CASE SQL_INT64
cType := "N"
nSize := 9
EXIT
CASE SQL_FLOAT
cType := "N"
nSize := 15
EXIT
CASE SQL_DOUBLE
cType := "N"
nSize := 15
EXIT
CASE SQL_TIMESTAMP
cType := "T"
nSize := 8
EXIT
CASE SQL_TYPE_DATE
cType := "D"
nSize := 8
EXIT
CASE SQL_TYPE_TIME
cType := "C"
nSize := 8
EXIT
CASE SQL_BLOB
cType := "M"
nSize := 10
EXIT
OTHERWISE
cType := "C"
nDec := 0
ENDSWITCH
AAdd( aNew, { cField, cType, nSize, nDec, cTable, cDomain } )
NEXT
ENDIF
RETURN aNew
STATIC FUNCTION RemoveSpaces( cQuery )
DO WHILE At( " ", cQuery ) != 0
cQuery := StrTran( cQuery, " ", " " )
ENDDO
RETURN cQuery
Reference in New Issue View Git Blame Copy Permalink