Hello,
Is anyone using Firebird?.
Thank you.
/*
* Firebird RDBMS low level (client api) interface code.
*
* Copyright 2003 Rodrigo Moreno <!-- e --><a href="mailto:rodrigo_moreno@yahoo.com">rodrigo_moreno@yahoo.com</a><!-- e -->
*
* 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 software; see the file COPYING.txt. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site <!-- m --><a class="postlink" href="https://www.gnu.org/">https://www.gnu.org/</a><!-- m -->).
*
* 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 <time.h>
/* NOTE: Ugly hack to avoid this error when compiled with BCC 5.8.2 and above:
Error E2238 <...>\Firebird-2.1.1\include\ibase.h 82: Multiple declaration for 'intptr_t' */
#if ( defined( __BORLANDC__ ) && __BORLANDC__ >= 1410 )
/* Prevent inclusion of <stdint.h> from hbdefs.h */
#define __STDINT_H
#endif
#include "hbapi.h"
#include "hbapierr.h"
#include "hbapiitm.h"
#include "ibase.h"
#ifndef ISC_INT64_FORMAT
#define ISC_INT64_FORMAT PFLL
#endif
/* GC object handlers */
static HB_GARBAGE_FUNC( FB_db_handle_release )
{
isc_db_handle * ph = ( isc_db_handle * ) Cargo;
/* Check if pointer is not NULL to avoid multiple freeing */
if( ph && *ph )
{
ISC_STATUS_ARRAY status;
/* Destroy the object */
isc_detach_database( status, ph );
/* set pointer to NULL to avoid multiple freeing */
*ph = 0;
}
}
static const HB_GC_FUNCS s_gcFB_db_handleFuncs =
{
FB_db_handle_release,
hb_gcDummyMark
};
static void hb_FB_db_handle_ret( isc_db_handle p )
{
if( p )
{
isc_db_handle * ph = ( isc_db_handle * )
hb_gcAllocate( sizeof( isc_db_handle ), &s_gcFB_db_handleFuncs );
*ph = p;
hb_retptrGC( ph );
}
else
hb_retptr( NULL );
}
static isc_db_handle hb_FB_db_handle_par( int iParam )
{
isc_db_handle * ph = ( isc_db_handle * ) hb_parptrGC( &s_gcFB_db_handleFuncs, iParam );
return ph ? *ph : 0;
}
/* API wrappers */
HB_FUNC( FBCREATEDB )
{
if( hb_pcount() == 6 )
{
isc_db_handle newdb = ( isc_db_handle ) 0;
isc_tr_handle trans = ( isc_tr_handle ) 0;
ISC_STATUS status[ 20 ];
char create_db[ 1024 ];
const char * db_name = hb_parcx( 1 );
const char * user = hb_parcx( 2 );
const char * pass = hb_parcx( 3 );
int page = hb_parni( 4 );
const char * charset = hb_parcx( 5 );
unsigned short dialect = ( unsigned short ) hb_parni( 6 );
hb_snprintf( create_db, sizeof( create_db ),
"CREATE DATABASE '%s' USER '%s' PASSWORD '%s' PAGE_SIZE = %i DEFAULT CHARACTER SET %s",
db_name, user, pass, page, charset );
if( isc_dsql_execute_immediate( status, &newdb, &trans, 0, create_db, dialect, NULL ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_retnl( 1 );
}
else
hb_retnl( 0 );
}
HB_FUNC( FBCONNECT )
{
ISC_STATUS_ARRAY status;
isc_db_handle db = ( isc_db_handle ) 0;
const char * db_connect = hb_parcx( 1 );
const char * user = hb_parcx( 2 );
const char * passwd = hb_parcx( 3 );
char dpb[ 128 ];
short i = 0;
int len;
/* TOFIX: Possible buffer overflow. Use hb_snprintf(). */
dpb[ i++ ] = isc_dpb_version1;
dpb[ i++ ] = isc_dpb_user_name;
len = ( int ) strlen( user );
if( len > ( int ) ( sizeof( dpb ) - i - 4 ) )
len = ( int ) ( sizeof( dpb ) - i - 4 );
dpb[ i++ ] = ( char ) len;
hb_strncpy( &( dpb[ i ] ), user, len );
i += ( short ) len;
dpb[ i++ ] = isc_dpb_password;
len = ( int ) strlen( passwd );
if( len > ( int ) ( sizeof( dpb ) - i - 2 ) )
len = ( int ) ( sizeof( dpb ) - i - 2 );
dpb[ i++ ] = ( char ) len;
hb_strncpy( &( dpb[ i ] ), passwd, len );
i += ( short ) len;
if( isc_attach_database( status, 0, db_connect, &db, i, dpb ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_FB_db_handle_ret( db );
}
HB_FUNC( FBCLOSE )
{
isc_db_handle db = hb_FB_db_handle_par( 1 );
if( db )
{
ISC_STATUS_ARRAY status;
if( isc_detach_database( status, &db ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_retnl( 1 );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBERROR )
{
char msg[ 1024 ];
isc_sql_interprete( ( short ) hb_parni( 1 ) /* sqlcode */,
msg, sizeof( msg ) );
hb_retc( msg );
}
HB_FUNC( FBSTARTTRANSACTION )
{
isc_db_handle db = hb_FB_db_handle_par( 1 );
if( db )
{
isc_tr_handle trans = ( isc_tr_handle ) 0;
ISC_STATUS_ARRAY status;
if( isc_start_transaction( status, &trans, 1, &db, 0, NULL ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_retptr( ( void * ) ( HB_PTRDIFF ) trans );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBCOMMIT )
{
isc_tr_handle trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_parptr( 1 );
if( trans )
{
ISC_STATUS_ARRAY status;
if( isc_commit_transaction( status, &trans ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_retnl( 1 );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBROLLBACK )
{
isc_tr_handle trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_parptr( 1 );
if( trans )
{
ISC_STATUS_ARRAY status;
if( isc_rollback_transaction( status, &trans ) )
hb_retnl( isc_sqlcode( status ) );
else
hb_retnl( 1 );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBEXECUTE )
{
isc_db_handle db = hb_FB_db_handle_par( 1 );
if( db )
{
isc_tr_handle trans = ( isc_tr_handle ) 0;
const char * exec_str = hb_parcx( 2 );
ISC_STATUS status[ 20 ];
ISC_STATUS status_rollback[ 20 ];
unsigned short dialect = ( unsigned short ) hb_parni( 3 );
if( HB_ISPOINTER( 4 ) )
trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_parptr( 4 );
else
{
if( isc_start_transaction( status, &trans, 1, &db, 0, NULL ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
}
if( isc_dsql_execute_immediate( status, &db, &trans, 0, exec_str, dialect, NULL ) )
{
if( ! HB_ISPOINTER( 4 ) )
isc_rollback_transaction( status_rollback, &trans );
hb_retnl( isc_sqlcode( status ) );
return;
}
if( ! HB_ISPOINTER( 4 ) )
{
if( isc_commit_transaction( status, &trans ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
}
hb_retnl( 1 );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBQUERY )
{
isc_db_handle db = hb_FB_db_handle_par( 1 );
if( db )
{
isc_tr_handle trans = ( isc_tr_handle ) 0;
ISC_STATUS_ARRAY status;
XSQLDA * sqlda;
isc_stmt_handle stmt = ( isc_stmt_handle ) 0;
XSQLVAR * var;
unsigned short dialect = ( unsigned short ) hb_parnidef( 3, SQL_DIALECT_V5 );
int i;
int num_cols;
PHB_ITEM qry_handle;
PHB_ITEM aNew;
PHB_ITEM aTemp;
if( HB_ISPOINTER( 4 ) )
trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_parptr( 4 );
else if( isc_start_transaction( status, &trans, 1, &db, 0, NULL ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
/* Allocate a statement */
if( isc_dsql_allocate_statement( status, &db, &stmt ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
/* Allocate an output SQLDA. Just to check number of columns */
sqlda = ( XSQLDA * ) hb_xgrab( XSQLDA_LENGTH( 1 ) );
sqlda->sqln = 1;
sqlda->version = 1;
/* Prepare the statement. */
if( isc_dsql_prepare( status, &trans, &stmt, 0, hb_parcx( 2 ), dialect, sqlda ) )
{
hb_xfree( sqlda );
hb_retnl( isc_sqlcode( status ) );
return;
}
/* Describe sql contents */
if( isc_dsql_describe( status, &stmt, dialect, sqlda ) )
{
hb_xfree( sqlda );
hb_retnl( isc_sqlcode( status ) );
return;
}
/* Relocate necessary number of columns */
if( sqlda->sqld > sqlda->sqln )
{
ISC_SHORT n = sqlda->sqld;
sqlda = ( XSQLDA * ) hb_xrealloc( sqlda, XSQLDA_LENGTH( n ) );
sqlda->sqln = n;
sqlda->version = 1;
if( isc_dsql_describe( status, &stmt, dialect, sqlda ) )
{
hb_xfree( sqlda );
hb_retnl( isc_sqlcode( status ) );
return;
}
}
num_cols = sqlda->sqld;
aNew = hb_itemArrayNew( num_cols );
aTemp = hb_itemNew( NULL );
for( i = 0, var = sqlda->sqlvar; i < sqlda->sqld; i++, var++ )
{
int dtype = ( var->sqltype & ~1 );
switch( dtype )
{
case SQL_VARYING:
var->sqltype = SQL_TEXT;
var->sqldata = ( char * ) hb_xgrab( sizeof( char ) * var->sqllen + 2 );
break;
case SQL_TEXT:
var->sqldata = ( char * ) hb_xgrab( sizeof( char ) * var->sqllen + 2 );
break;
case SQL_LONG:
var->sqltype = SQL_LONG;
var->sqldata = ( char * ) hb_xgrab( sizeof( long ) );
break;
default:
var->sqldata = ( char * ) hb_xgrab( sizeof( char ) * var->sqllen );
break;
}
if( var->sqltype & 1 )
var->sqlind = ( short * ) hb_xgrab( sizeof( short ) );
hb_arrayNew( aTemp, 7 );
hb_arraySetC( aTemp, 1, sqlda->sqlvar[ i ].sqlname );
hb_arraySetNL( aTemp, 2, ( long ) dtype );
hb_arraySetNL( aTemp, 3, sqlda->sqlvar[ i ].sqllen );
hb_arraySetNL( aTemp, 4, sqlda->sqlvar[ i ].sqlscale );
hb_arraySetC( aTemp, 5, sqlda->sqlvar[ i ].relname );
hb_arraySetNL( aTemp, 6, sqlda->sqlvar[ i ].aliasname_length ); /* support for aliases */
hb_arraySetC( aTemp, 7, sqlda->sqlvar[ i ].aliasname ); /* support for aliases */
hb_arraySetForward( aNew, i + 1, aTemp );
}
hb_itemRelease( aTemp );
if( ! sqlda->sqld )
{
/* Execute and commit non-select querys */
if( isc_dsql_execute( status, &trans, &stmt, dialect, NULL ) )
{
hb_itemRelease( aNew );
hb_retnl( isc_sqlcode( status ) );
return;
}
}
else
{
if( isc_dsql_execute( status, &trans, &stmt, dialect, sqlda ) )
{
hb_itemRelease( aNew );
hb_retnl( isc_sqlcode( status ) );
return;
}
}
qry_handle = hb_itemArrayNew( 6 );
hb_arraySetPtr( qry_handle, 1, ( void * ) ( HB_PTRDIFF ) stmt );
hb_arraySetPtr( qry_handle, 2, ( void * ) ( HB_PTRDIFF ) sqlda );
if( ! HB_ISPOINTER( 4 ) )
hb_arraySetPtr( qry_handle, 3, ( void * ) ( HB_PTRDIFF ) trans );
hb_arraySetNL( qry_handle, 4, ( long ) num_cols );
hb_arraySetNI( qry_handle, 5, ( int ) dialect );
hb_arraySetForward( qry_handle, 6, aNew );
hb_itemReturnRelease( qry_handle );
hb_itemRelease( aNew );
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}
HB_FUNC( FBFETCH )
{
PHB_ITEM aParam = hb_param( 1, HB_IT_ARRAY );
if( aParam )
{
isc_stmt_handle stmt = ( isc_stmt_handle ) ( HB_PTRDIFF ) hb_itemGetPtr( hb_itemArrayGet( aParam, 1 ) );
XSQLDA * sqlda = ( XSQLDA * ) hb_itemGetPtr( hb_itemArrayGet( aParam, 2 ) );
ISC_STATUS_ARRAY status;
unsigned short dialect = ( unsigned short ) hb_itemGetNI( hb_itemArrayGet( aParam, 5 ) );
/* TOFIX */
hb_retnl( isc_dsql_fetch( status,
&stmt,
dialect,
sqlda ) == 100 ? -1 : isc_sqlcode( status ) );
}
else
hb_retnl( 0 );
}
HB_FUNC( FBFREE )
{
PHB_ITEM aParam = hb_param( 1, HB_IT_ARRAY );
if( aParam )
{
isc_stmt_handle stmt = ( isc_stmt_handle ) ( HB_PTRDIFF ) hb_itemGetPtr( hb_itemArrayGet( aParam, 1 ) );
XSQLDA * sqlda = ( XSQLDA * ) hb_itemGetPtr( hb_itemArrayGet( aParam, 2 ) );
isc_tr_handle trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_itemGetPtr( hb_itemArrayGet( aParam, 3 ) );
ISC_STATUS_ARRAY status;
if( isc_dsql_free_statement( status, &stmt, DSQL_drop ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
if( trans && isc_commit_transaction( status, &trans ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
/* TOFIX: Freeing pointer received as parameter? We should at least set the item NULL. */
if( sqlda )
hb_xfree( sqlda );
hb_retnl( 1 );
}
else
hb_retnl( 0 );
}
HB_FUNC( FBGETDATA )
{
PHB_ITEM aParam = hb_param( 1, HB_IT_ARRAY );
if( aParam )
{
XSQLVAR * var;
XSQLDA * sqlda = ( XSQLDA * ) hb_itemGetPtr( hb_itemArrayGet( aParam, 2 ) );
ISC_STATUS_ARRAY status;
int pos = hb_parni( 2 ) - 1;
if( ! sqlda || pos < 0 || pos >= sqlda->sqln )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
var = sqlda->sqlvar + pos;
if( ( var->sqltype & 1 ) && ( *var->sqlind < 0 ) )
{
hb_ret(); /* null field */
}
else
{
struct tm times;
char date_s[ 25 ];
char data[ 1024 ];
short dtype = var->sqltype & ~1;
switch( dtype )
{
case SQL_TEXT:
case SQL_VARYING:
hb_retclen( var->sqldata, var->sqllen );
break;
case SQL_TIMESTAMP:
isc_decode_timestamp( ( ISC_TIMESTAMP * ) var->sqldata, × );
hb_snprintf( date_s, sizeof( date_s ), "%04d-%02d-%02d %02d:%02d:%02d.%04d",
times.tm_year + 1900,
times.tm_mon + 1,
times.tm_mday,
times.tm_hour,
times.tm_min,
times.tm_sec,
( int ) ( ( ( ISC_TIMESTAMP * ) var->sqldata )->timestamp_time % 10000 ) );
hb_snprintf( data, sizeof( data ), "%*s ", 24, date_s );
hb_retc( data );
break;
case SQL_TYPE_DATE:
isc_decode_sql_date( ( ISC_DATE * ) var->sqldata, × );
hb_snprintf( date_s, sizeof( date_s ), "%04d-%02d-%02d", times.tm_year + 1900, times.tm_mon + 1, times.tm_mday );
hb_snprintf( data, sizeof( data ), "%*s ", 8, date_s );
hb_retc( data );
break;
case SQL_TYPE_TIME:
isc_decode_sql_time( ( ISC_TIME * ) var->sqldata, × );
hb_snprintf( date_s, sizeof( date_s ), "%02d:%02d:%02d.%04d",
times.tm_hour,
times.tm_min,
times.tm_sec,
( int ) ( ( *( ( ISC_TIME * ) var->sqldata ) ) % 10000 ) );
hb_snprintf( data, sizeof( data ), "%*s ", 13, date_s );
hb_retc( data );
break;
case SQL_BLOB:
{
ISC_QUAD * blob_id = ( ISC_QUAD * ) var->sqldata;
hb_retptr( ( void * ) blob_id );
break;
}
case SQL_SHORT:
case SQL_LONG:
case SQL_INT64:
{
ISC_INT64 value;
short field_width;
short dscale;
switch( dtype )
{
case SQL_SHORT:
value = ( ISC_INT64 ) *( short * ) var->sqldata;
field_width = 6;
break;
case SQL_LONG:
value = ( ISC_INT64 ) *( long * ) var->sqldata;
field_width = 11;
break;
case SQL_INT64:
value = ( ISC_INT64 ) *( ISC_INT64 * ) var->sqldata;
field_width = 21;
break;
default:
value = 0;
field_width = 10;
break;
}
dscale = var->sqlscale;
if( dscale < 0 )
{
ISC_INT64 tens = 1;
short i;
for( i = 0; i > dscale; i-- )
tens *= 10;
if( value >= 0 )
hb_snprintf( data, sizeof( data ), "%*" ISC_INT64_FORMAT "d.%0*" ISC_INT64_FORMAT "d",
field_width - 1 + dscale,
( ISC_INT64 ) value / tens,
-dscale,
( ISC_INT64 ) value % tens );
else if( ( value / tens ) != 0 )
hb_snprintf( data, sizeof( data ), "%*" ISC_INT64_FORMAT "d.%0*" ISC_INT64_FORMAT "d",
field_width - 1 + dscale,
( ISC_INT64 ) ( value / tens ),
-dscale,
( ISC_INT64 ) -( value % tens ) );
else
hb_snprintf( data, sizeof( data ), "%*s.%0*" ISC_INT64_FORMAT "d",
field_width - 1 + dscale,
"-0",
-dscale,
( ISC_INT64 ) -( value % tens ) );
}
else if( dscale )
hb_snprintf( data, sizeof( data ), "%*" ISC_INT64_FORMAT "d%0*d", field_width, ( ISC_INT64 ) value, dscale, 0 );
else
hb_snprintf( data, sizeof( data ), "%*" ISC_INT64_FORMAT "d", field_width, ( ISC_INT64 ) value );
hb_retc( data );
break;
}
case SQL_FLOAT:
hb_snprintf( data, sizeof( data ), "%15g ", *( float * ) ( var->sqldata ) );
hb_retc( data );
break;
case SQL_DOUBLE:
hb_snprintf( data, sizeof( data ), "%24f ", *( double * ) ( var->sqldata ) );
hb_retc( data );
break;
default:
hb_ret();
break;
}
}
}
}
HB_FUNC( FBGETBLOB )
{
isc_db_handle db = hb_FB_db_handle_par( 1 );
if( db )
{
ISC_STATUS_ARRAY status;
isc_tr_handle trans = ( isc_tr_handle ) 0;
isc_blob_handle blob_handle = ( isc_blob_handle ) 0;
short blob_seg_len;
char blob_segment[ 512 ];
ISC_QUAD * blob_id = ( ISC_QUAD * ) hb_parptr( 2 );
ISC_STATUS blob_stat;
if( HB_ISPOINTER( 3 ) )
trans = ( isc_tr_handle ) ( HB_PTRDIFF ) hb_parptr( 3 );
else
{
if( isc_start_transaction( status, &trans, 1, &db, 0, NULL ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
}
if( isc_open_blob2( status, &db, &trans, &blob_handle, blob_id, 0, NULL ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
/* Get blob segments and their lengths and print each segment. */
blob_stat = isc_get_segment( status, &blob_handle,
( unsigned short * ) &blob_seg_len,
sizeof( blob_segment ), blob_segment );
if( blob_stat == 0 || status[ 1 ] == isc_segment )
{
PHB_ITEM aNew = hb_itemArrayNew( 0 );
while( blob_stat == 0 || status[ 1 ] == isc_segment )
{
char p[ 1024 ];
PHB_ITEM temp;
hb_snprintf( p, sizeof( p ), "%*.*s", blob_seg_len, blob_seg_len, blob_segment );
temp = hb_itemPutC( NULL, p );
hb_arrayAdd( aNew, temp );
hb_itemRelease( temp );
blob_stat = isc_get_segment( status, &blob_handle,
( unsigned short * ) &blob_seg_len,
sizeof( blob_segment ), blob_segment );
}
hb_itemReturnRelease( aNew );
}
if( isc_close_blob( status, &blob_handle ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
if( ! HB_ISPOINTER( 3 ) )
{
if( isc_commit_transaction( status, &trans ) )
{
hb_retnl( isc_sqlcode( status ) );
return;
}
}
}
else
hb_errRT_BASE( EG_ARG, 2020, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
}/*
* Firebird RDBMS low level (client api) interface code.
*
* Copyright 2003 Rodrigo Moreno <!-- e --><a href="mailto:rodrigo_moreno@yahoo.com">rodrigo_moreno@yahoo.com</a><!-- e -->
*
* 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 software; see the file COPYING.txt. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site <!-- m --><a class="postlink" href="https://www.gnu.org/">https://www.gnu.org/</a><!-- m -->).
*
* 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
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
::lError := .F.
::nError := 0
::StartedTrans := .F.
::Dialect := hb_defaultValue( nDialect, 1 )
::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 result := .F.
LOCAL cQuery := ;
"select rdb$relation_name" + ;
" from rdb$relations" + ;
" where rdb$relation_name = " + '"' + Upper( cTable ) + '"'
LOCAL 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 := ;
"select rdb$relation_name" + ;
" from rdb$relations" + ;
' where rdb$relation_name not like "RDB$%"' + ;
" and rdb$view_blr is null" + ;
" order by 1"
LOCAL qry := FBQuery( ::db, RemoveSpaces( cQuery ), ::dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
AAdd( result, hb_defaultValue( FBGetData( qry, 1 ), "" ) )
ENDDO
FBFree( qry )
ENDIF
RETURN result
METHOD TableStruct( cTable ) CLASS TFbServer
LOCAL result := {}
LOCAL cType, nSize, cDomain, cField, nType, nDec
LOCAL cQuery := ;
"select" + ;
" a.rdb$field_name," + ;
" b.rdb$field_type," + ;
" b.rdb$field_length," + ;
" b.rdb$field_scale * -1," + ;
" a.rdb$field_source" + ;
" from" + ;
" rdb$relation_fields a, rdb$fields b" + ;
" where" + ;
" a.rdb$field_source = b.rdb$field_name" + ;
" and a.rdb$relation_name = " + '"' + Upper( cTable ) + '"' + ;
" order by" + ;
" a.rdb$field_position"
LOCAL qry := FBQuery( ::db, RemoveSpaces( cQuery ), ::dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
cField := hb_defaultValue( FBGetData( qry, 1 ), "" )
nType := Val( hb_defaultValue( FBGetData( qry, 2 ), "" ) )
nSize := Val( hb_defaultValue( FBGetData( qry, 3 ), "" ) )
nDec := Val( hb_defaultValue( FBGetData( qry, 4 ), "" ) )
cDomain := hb_defaultValue( 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
LOCAL aTables := oRow:GetTables()
IF ! HB_ISNUMERIC( ::db ) .AND. Len( aTables ) == 1
// Cannot delete joined tables
IF ! HB_ISSTRING( cWhere )
aKeys := oRow:GetKeyField()
cWhere := ""
FOR EACH i IN aKeys
nField := oRow:FieldPos( i )
xField := oRow:FieldGet( nField )
cWhere += i + "=" + DataToSql( xField )
IF ! i:__enumIsLast()
cWhere += ","
ENDIF
NEXT
ENDIF
IF ! Empty( cWhere )
result := ::Execute( "DELETE FROM " + aTables[ 1 ] + " WHERE " + cWhere )
ENDIF
ENDIF
RETURN result
METHOD Append( oRow ) CLASS TFbServer
LOCAL result := .F.
LOCAL cQuery, i
LOCAL 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 := hb_StrShrink( cQuery ) + ") VALUES ("
FOR i := 1 TO oRow:FCount()
IF oRow:Changed( i )
cQuery += DataToSql( oRow:FieldGet( i ) ) + ","
ENDIF
NEXT
cQuery := hb_StrShrink( cQuery ) + ")"
result := ::Execute( cQuery )
ENDIF
RETURN result
METHOD Update( oRow, cWhere ) CLASS TFbServer
LOCAL result := .F.
LOCAL aKeys, cQuery, i, nField, xField
LOCAL aTables := oRow:GetTables()
IF ! HB_ISNUMERIC( ::db ) .AND. Len( aTables ) == 1
// Cannot insert joined tables
IF ! HB_ISSTRING( cWhere )
aKeys := oRow:GetKeyField()
cWhere := ""
FOR EACH i IN aKeys
nField := oRow:FieldPos( i )
xField := oRow:FieldGet( nField )
cWhere += i + "=" + DataToSql( xField )
IF ! i:__enumIsLast()
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 ! Empty( cWhere )
result := ::Execute( hb_StrShrink( cQuery ) + " WHERE " + cWhere )
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 ]
::aStruct := StructConvert( qry[ 6 ], ::db, ::dialect )
::lError := .F.
::nError := 0
::qry := qry
/* Tables in query */
FOR EACH i IN ::aStruct
IF hb_AScan( aTable, i[ 5 ], , , .T. ) == 0
AAdd( aTable, 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 .AND. ! ::Closed
fetch_stat := FBFetch( ::qry )
::nRecno++
IF fetch_stat == 0
::lBof := .F.
result := .T.
ELSE
::lEof := .T.
ENDIF
ENDIF
RETURN result
METHOD Struct() CLASS TFbQuery
LOCAL result := {}
LOCAL i
IF ! ::lError
FOR EACH i IN ::aStruct
AAdd( result, { i[ 1 ], i[ 2 ], i[ 3 ], i[ 4 ] } ) // DBS_NAME, DBS_TYPE, DBS_LEN, DBS_DEC
NEXT
ENDIF
RETURN result
METHOD FieldPos( cField ) CLASS TFbQuery
IF ! ::lError
cField := RTrim( Upper( cField ) )
RETURN AScan( ::aStruct, {| x | x[ 1 ] == cField } )
ENDIF
RETURN 0
METHOD FieldName( nField ) CLASS TFbQuery
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 1 ]
ENDIF
RETURN NIL
METHOD FieldType( nField ) CLASS TFbQuery
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 2 ]
ENDIF
RETURN NIL
METHOD FieldLen( nField ) CLASS TFbQuery
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 3 ]
ENDIF
RETURN NIL
METHOD FieldDec( nField ) CLASS TFbQuery
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 4 ]
ENDIF
RETURN NIL
METHOD FieldGet( nField ) CLASS TFbQuery
LOCAL result, aBlob, i
IF ! ::lError .AND. nField >= 1 .AND. nField <= Len( ::aStruct ) .AND. ! ::closed
/* TODO: Convert to right data type */
result := FBGetData( ::qry, nField )
SWITCH ::aStruct[ nField ][ 2 ]
CASE "M" /* Blob */
IF HB_ISPOINTER( result )
aBlob := FBGetBlob( ::db, result )
result := ""
IF HB_ISARRAY( aBlob )
FOR EACH i IN aBlob
result += i
NEXT
ENDIF
#if 0
result := FBGetBlob( ::db, result )
#endif
ELSE
result := ""
ENDIF
EXIT
CASE "N"
result := iif( HB_ISSTRING( result ), Val( result ), 0 )
EXIT
CASE "D"
result := hb_SToD( result )
EXIT
CASE "L"
result := ( HB_ISSTRING( result ) .AND. Val( result ) == 1 )
EXIT
ENDSWITCH
ENDIF
RETURN result
METHOD Getrow() CLASS TFbQuery
LOCAL aRow
LOCAL i
IF ! ::lError .AND. ! ::closed
aRow := Array( ::numcols )
FOR i := 1 TO ::numcols
aRow[ i ] := ::FieldGet( i )
NEXT
RETURN TFBRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables )
ENDIF
RETURN NIL
METHOD GetBlankRow() CLASS TFbQuery
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
RETURN TFBRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables )
ENDIF
RETURN NIL
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
IF nField >= 1 .AND. nField <= Len( ::aRow )
RETURN ::aChanged[ nField ] != NIL
ENDIF
RETURN NIL
METHOD FieldGet( nField ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aRow )
RETURN ::aRow[ nField ]
ENDIF
RETURN NIL
METHOD FieldPut( nField, Value ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aRow )
::aChanged[ nField ] := .T.
RETURN ::aRow[ nField ] := Value
ENDIF
RETURN NIL
METHOD FieldName( nField ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 1 ]
ENDIF
RETURN NIL
METHOD FieldPos( cField ) CLASS TFbRow
cField := RTrim( Upper( cField ) )
RETURN AScan( ::aStruct, {| x | x[ 1 ] == cField } )
METHOD FieldType( nField ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 2 ]
ENDIF
RETURN NIL
METHOD FieldLen( nField ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 3 ]
ENDIF
RETURN NIL
METHOD FieldDec( nField ) CLASS TFbRow
IF nField >= 1 .AND. nField <= Len( ::aStruct )
RETURN ::aStruct[ nField ][ 4 ]
ENDIF
RETURN NIL
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" + ;
" a.rdb$field_name" + ;
" from" + ;
" rdb$index_segments a," + ;
" rdb$relation_constraints b" + ;
" where" + ;
" a.rdb$index_name = b.rdb$index_name and" + ;
' b.rdb$constraint_type = "PRIMARY KEY" and' + ;
" b.rdb$relation_name = " + DataToSql( cTable ) + ;
" order by" + ;
" b.rdb$relation_name," + ;
" a.rdb$field_position"
qry := FBQuery( db, RemoveSpaces( cQuery ), dialect )
IF HB_ISARRAY( qry )
DO WHILE FBFetch( qry ) == 0
AAdd( aKeys, RTrim( hb_defaultValue( 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 '"' + hb_DToC( xField, "mm/dd/yyyy" ) + '"'
CASE "N" ; RETURN hb_ntos( xField )
CASE "L" ; RETURN iif( xField, "1", "0" )
ENDSWITCH
RETURN ""
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 cTables := ""
LOCAL cFields := ""
/* create table list and field list */
FOR EACH i IN aStru
cTables += DataToSql( i[ 5 ] )
cFields += DataToSql( i[ 1 ] )
IF ! i:__enumIsLast()
cTables += ","
cFields += ","
ENDIF
NEXT
/* Look for domains */
cQuery := ;
"select rdb$relation_name, rdb$field_name, rdb$field_source" + ;
" from rdb$relation_fields" + ;
' where rdb$field_name not like "RDB$%"' + ;
" and rdb$relation_name in (" + cTables + ")" + ;
" and rdb$field_name in (" + cFields + ")"
IF HB_ISARRAY( qry := FBQuery( db, RemoveSpaces( cQuery ), dialect ) )
DO WHILE FBFetch( qry ) == 0
AAdd( aDomains, { ;
hb_defaultValue( FBGetData( qry, 1 ), "" ), ;
hb_defaultValue( FBGetData( qry, 2 ), "" ), ;
hb_defaultValue( FBGetData( qry, 3 ), "" ) } )
ENDDO
FBFree( qry )
ENDIF
FOR EACH i IN aStru
cField := RTrim( i[ 7 ] )
nType := i[ 2 ]
nSize := i[ 3 ]
nDec := i[ 4 ] * -1
cTable := RTrim( i[ 5 ] )
nVal := AScan( aDomains, {| x | RTrim( x[ 1 ] ) == cTable .AND. RTrim( x[ 2 ] ) == cField } )
cDomain := iif( nVal > 0, aDomains[ nVal ][ 3 ], "" )
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
RETURN aNew
STATIC FUNCTION RemoveSpaces( cQuery )
DO WHILE " " $ cQuery
cQuery := StrTran( cQuery, " ", " " )
ENDDO
RETURN cQuery#require "hbfbird"
#include "dbstruct.ch"
PROCEDURE Main()
LOCAL oServer, oQuery, oRow, i, x, aKey
LOCAL cServer := "localhost:"
LOCAL cDatabase := hb_FNameExtSet( hb_ProgName(), ".fdb" )
LOCAL cUser := "SYSDBA"
LOCAL cPass := "masterkey"
LOCAL nPageSize := 1024
LOCAL cCharSet := "UTF8"
LOCAL nDialect := 1
IF hb_FileExists( cDatabase )
FErase( cDatabase )
ENDIF
? FBCreateDB( cServer + cDatabase, cUser, cPass, nPageSize, cCharSet, nDialect )
? "Connecting..."
oServer := TFBServer():New( cServer + cDatabase, cUser, cPass, nDialect )
IF oServer:NetErr()
? oServer:Error()
RETURN
ENDIF
? "Tables..."
FOR EACH i IN oServer:ListTables()
? i
NEXT
? "Using implicit transaction..."
IF oServer:TableExists( "TEST" )
oServer:Execute( "DROP TABLE Test" )
oServer:Execute( "DROP DOMAIN boolean_field" )
ENDIF
? "Creating domain for boolean fields..."
oServer:Execute( "create domain boolean_field as smallint default 0 not null check (value in (0,1))" )
? "Creating test table..."
oServer:StartTransaction()
oServer:Execute( ;
"CREATE TABLE test(" + ;
" Code SmallInt not null primary key," + ;
" dept Integer," + ;
" Name Varchar(40)," + ;
" Sales boolean_field," + ;
" Tax Float," + ;
" Salary Double Precision," + ;
" Budget Numeric(12,2)," + ;
" Discount Decimal(5,2)," + ;
" Creation Date," + ;
" Description blob sub_type 1 segment size 40 )" )
IF oServer:NetErr()
? oServer:Error()
ENDIF
oServer:Commit()
oServer:Query( "SELECT code, dept, name, sales, salary, creation FROM test" )
WAIT
? "Structure of test table"
FOR EACH i IN oServer:TableStruct( "test" )
?
FOR EACH x IN i
?? x, ""
NEXT
NEXT
? "Inserting, declared transaction control"
oServer:StartTransaction()
FOR i := 1 TO 100
oServer:Execute( ;
"INSERT INTO test(code, dept, name, sales, tax, salary, budget, Discount, Creation, Description) " + ;
'VALUES( ' + hb_ntos( i ) + ', 2, "TEST", 1, 5, 3000, 1500.2, 7.5, "2003-12-22", "Short Description about what ?")' )
IF oServer:NetErr()
? oServer:error()
ENDIF
NEXT
oServer:Commit()
oQuery := oServer:Query( "SELECT code, name, description, sales FROM test" )
FOR EACH i IN oQuery:Struct()
? i[ DBS_NAME ], i[ DBS_TYPE ], i[ DBS_LEN ], i[ DBS_DEC ]
NEXT
aKey := oQuery:GetKeyField()
? "Fields:", oQuery:FCount()
? "Primary Key:", aKey[ 1 ]
oRow := oQuery:Blank()
? ;
oRow:FCount(), ;
oRow:FieldPos( "code" ), ;
oRow:FieldGet( 1 ), ;
oRow:FieldName( 1 ), ;
oRow:FieldType( 1 ), ;
oRow:FieldDec( 1 ), ;
oRow:FieldLen( 1 ), ;
Len( oRow:Getkeyfield() )
oRow:FieldPut( 1, 150 )
oRow:FieldPut( 2, "MY TEST" )
? oRow:FieldGet( 1 ), oRow:FieldGet( 2 )
? oServer:Append( oRow )
? oServer:Delete( oQuery:blank(), "code = 200" )
? oServer:Execute( "error caused intentionaly" )
DO WHILE ! oQuery:Eof()
oQuery:Skip()
? ;
oQuery:FieldGet( oQuery:FieldPos( "code" ) ), ;
oQuery:FieldGet( 4 ), ;
oQuery:FieldGet( 2 ), ;
oQuery:FieldName( 1 ), ;
oQuery:FieldType( 1 ), ;
oQuery:FieldDec( 1 ), ;
oQuery:FieldLen( 1 ), ;
oQuery:FieldGet( 3 )
IF oQuery:RecNo() == 50
oRow := oQuery:getrow()
oRow:FieldPut( 2, "My Second test" )
? "Update:", oServer:Update( oRow )
ENDIF
IF oQuery:RecNo() == 60
oRow := oQuery:getrow()
? "Delete:", oServer:Delete( oRow )
ENDIF
ENDDO
? "Delete:", oServer:Delete( oQuery:Blank(), "code = 70" )
oQuery:Refresh()
DO WHILE oQuery:Fetch()
oRow := oQuery:getrow()
? ;
oRow:FieldGet( oRow:FieldPos( "code" ) ), ;
oRow:FieldGet( 4 ), ;
oRow:FieldGet( 2 ), ;
oRow:FieldName( 1 ), ;
oRow:FieldType( 1 ), ;
oRow:FieldDec( 1 ), ;
oRow:FieldLen( 1 ), ;
oRow:FieldGet( 3 )
ENDDO
oQuery:Destroy()
oServer:Destroy()
? "Closing..."
RETURNtfirebird.obj : error LNK2001: unresolved external symbol _HB_FUN_HB_DEFAULTVALUE