From 043cd01674f933b2e0e9ea287f6ca2d6d53949a5 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Thu, 15 Nov 2007 19:48:32 +0000 Subject: [PATCH] 2007-11-15 20:44 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) + contrib/firebird + contrib/firebird/Makefile + contrib/firebird/make_b32.bat + contrib/firebird/make_vc.bat + contrib/firebird/common.mak + contrib/firebird/tfirebird.prg + contrib/firebird/firebird.c + contrib/firebird/readme.txt + contrib/firebird/test + contrib/firebird/test/Makefile + contrib/firebird/test/bld_b32.bat + contrib/firebird/test/simple.prg + contrib/firebird/test/test.prg + contrib/firebird/test/stress.prg + contrib/firebird/test/testapi.c + Added firebird library, with some warnings and other minor things fixed, and Harbour std non-GNU make / build files added. ; TOFIX: There is still a potentially dangerous warning to be fixed in FBGETBLOB(). * contrib/hbzlib/make_b32.bat * contrib/hbzlib/make_vc.bat ! Fixed to not override C_USR set by user. + contrib/mysql/test + contrib/mysql/test/test.prg - contrib/mysql/test.prg * Moved test file to test dir. --- harbour/ChangeLog | 31 + harbour/contrib/firebird/Makefile | 17 + harbour/contrib/firebird/common.mak | 18 + harbour/contrib/firebird/firebird.c | 737 ++++++++++++++ harbour/contrib/firebird/make_b32.bat | 78 ++ harbour/contrib/firebird/make_vc.bat | 94 ++ harbour/contrib/firebird/readme.txt | 55 ++ harbour/contrib/firebird/test/Makefile | 32 + harbour/contrib/firebird/test/bld_b32.bat | 80 ++ harbour/contrib/firebird/test/simple.prg | 188 ++++ harbour/contrib/firebird/test/stress.prg | 134 +++ harbour/contrib/firebird/test/test.prg | 77 ++ harbour/contrib/firebird/test/testapi.c | 403 ++++++++ harbour/contrib/firebird/tfirebird.prg | 1063 +++++++++++++++++++++ harbour/contrib/hbzlib/make_b32.bat | 2 +- harbour/contrib/hbzlib/make_vc.bat | 2 +- harbour/contrib/mysql/{ => test}/test.prg | 0 17 files changed, 3009 insertions(+), 2 deletions(-) create mode 100644 harbour/contrib/firebird/Makefile create mode 100644 harbour/contrib/firebird/common.mak create mode 100644 harbour/contrib/firebird/firebird.c create mode 100644 harbour/contrib/firebird/make_b32.bat create mode 100644 harbour/contrib/firebird/make_vc.bat create mode 100644 harbour/contrib/firebird/readme.txt create mode 100644 harbour/contrib/firebird/test/Makefile create mode 100644 harbour/contrib/firebird/test/bld_b32.bat create mode 100644 harbour/contrib/firebird/test/simple.prg create mode 100644 harbour/contrib/firebird/test/stress.prg create mode 100644 harbour/contrib/firebird/test/test.prg create mode 100644 harbour/contrib/firebird/test/testapi.c create mode 100644 harbour/contrib/firebird/tfirebird.prg rename harbour/contrib/mysql/{ => test}/test.prg (100%) diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 1cbcf5b7f4..6a296bd7ca 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,37 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-11-15 20:44 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) + + contrib/firebird + + contrib/firebird/Makefile + + contrib/firebird/make_b32.bat + + contrib/firebird/make_vc.bat + + contrib/firebird/common.mak + + contrib/firebird/tfirebird.prg + + contrib/firebird/firebird.c + + contrib/firebird/readme.txt + + contrib/firebird/test + + contrib/firebird/test/Makefile + + contrib/firebird/test/bld_b32.bat + + contrib/firebird/test/simple.prg + + contrib/firebird/test/test.prg + + contrib/firebird/test/stress.prg + + contrib/firebird/test/testapi.c + + Added firebird library, with some warnings and other + minor things fixed, and Harbour std non-GNU make / build + files added. + ; TOFIX: There is still a potentially dangerous + warning to be fixed in FBGETBLOB(). + + * contrib/hbzlib/make_b32.bat + * contrib/hbzlib/make_vc.bat + ! Fixed to not override C_USR set by user. + + + contrib/mysql/test + + contrib/mysql/test/test.prg + - contrib/mysql/test.prg + * Moved test file to test dir. + 2007-11-15 00:20 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) * contrib/xhb/make_b32.bat * contrib/xhb/make_vc.bat diff --git a/harbour/contrib/firebird/Makefile b/harbour/contrib/firebird/Makefile new file mode 100644 index 0000000000..9ddd1fe990 --- /dev/null +++ b/harbour/contrib/firebird/Makefile @@ -0,0 +1,17 @@ +# +# $Id: Makefile 4853 2001-12-25 16:51:58Z lculik $ +# + +ROOT = ../../ + +CFLAGS += -I/opt/firebird/include + +C_SOURCES=\ + firebird.c \ + +PRG_SOURCES=\ + tfirebird.prg \ + +LIBNAME=firebird + +include $(TOP)$(ROOT)config/lib.cf diff --git a/harbour/contrib/firebird/common.mak b/harbour/contrib/firebird/common.mak new file mode 100644 index 0000000000..5b8f4e905c --- /dev/null +++ b/harbour/contrib/firebird/common.mak @@ -0,0 +1,18 @@ +# +# $Id: common.mak 7935 2007-11-10 11:31:17Z vszakats $ +# + +LIBNAME = firebird + +LIB_PATH = $(LIB_DIR)\$(LIBNAME)$(LIBEXT) + +# +# LIB rules +# + +LIB_OBJS = \ + $(OBJ_DIR)\firebird$(OBJEXT) \ + $(OBJ_DIR)\tfirebird$(OBJEXT) \ + +all: \ + $(LIB_PATH) \ diff --git a/harbour/contrib/firebird/firebird.c b/harbour/contrib/firebird/firebird.c new file mode 100644 index 0000000000..fa3ec8a0ee --- /dev/null +++ b/harbour/contrib/firebird/firebird.c @@ -0,0 +1,737 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +/* + * xHarbour Project source code: + * Firebird RDBMS low level (client api) interface code. + * + * Copyright 2003 Rodrigo Moreno rodrigo_moreno@yahoo.com + * www - http://www.xharbour.org + * + * 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. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * 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. + * + * See doc/license.txt for licensing terms. + * + */ + +#define _CLIPDEFS_H +#if defined(HB_OS_WIN_32_USED) + #include +#endif + +#include +#include +#include +#include + +#include "extend.api" +#include "item.api" +#include "hbapiitm.h" +#include "ibase.h" + +#define DIALECT 1 +#define MAX_FIELDS 5 +#define MAX_LEN 256 +#define MAX_BUFFER 1024 + +#define ERREXIT(status) { _retnl(isc_sqlcode(status)); return; } + +#ifndef ISC_INT64_FORMAT + +#if (defined(_MSC_VER) && defined(WIN32)) || (defined(__BORLANDC__) && defined(__WIN32__)) +#define ISC_INT64_FORMAT "I64" +#else +#define ISC_INT64_FORMAT "ll" +#endif +#endif + +HB_FUNC(FBCREATEDB) +{ + isc_db_handle newdb = NULL; + isc_tr_handle trans = NULL; + long status[20]; + char create_db[MAX_BUFFER]; + + char *db_name; + char *user; + char *pass; + char *charset; + int page; + int dialect; + + if (hb_pcount() != 6) + { + _retni(0); + return; + } + + db_name = hb_parcx(1); + user = hb_parcx(2); + pass = hb_parcx(3); + page = hb_parni(4); + charset = hb_parcx(5); + dialect = hb_parni(6); + + sprintf(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)) + ERREXIT(status); + + _retni(1); +} + + +HB_FUNC(FBCONNECT) +{ + ISC_STATUS status[MAX_FIELDS]; + isc_db_handle db = NULL; + char *db_connect = NULL; + char *user = NULL; + char *passwd = NULL; + char dpb[128]; + int i = 0, len; + + PHB_ITEM db_handle; + + if (hb_parinfo(1)) + db_connect = hb_parcx(1); + + if (hb_parinfo(2)) + user = hb_parcx(2); + + if (hb_parinfo(3)) + passwd = hb_parcx(3); + + dpb[i++] = isc_dpb_version1; + + dpb[i++] = isc_dpb_user_name; + len = strlen(user); + dpb[i++] = (char) len; + strncpy(&(dpb[i]), user, len); + i += len; + + dpb[i++] = isc_dpb_password; + len = strlen (passwd); + dpb[i++] = len; + strncpy(&(dpb[i]), passwd, len); + i += len; + + if ( isc_attach_database ( status, 0, db_connect, &db, i, dpb ) ) + ERREXIT(status); + + db_handle = hb_itemPutPtr( NULL, ( void * ) db ); + _itemReturn(db_handle); + _itemRelease(db_handle); +} + + +HB_FUNC(FBCLOSE) +{ + isc_db_handle db = NULL; + long status[20]; + + db = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + + if ( isc_detach_database ( status, &db ) ) + ERREXIT(status); + + _retnl(1); +} + + +HB_FUNC(FBERROR) +{ + int sqlcode; + char msg[MAX_BUFFER]; + + sqlcode = hb_parni(1); + + isc_sql_interprete(sqlcode, msg, 512); + + _retc(msg); +} + +HB_FUNC(FBSTARTTRANSACTION) +{ + isc_db_handle db = NULL; + isc_tr_handle trans = NULL; + long status[MAX_FIELDS]; + + PHB_ITEM var; + + db = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + + if (isc_start_transaction(status, &trans, 1, &db, 0, NULL)) + ERREXIT(status); + + var = hb_itemPutPtr( NULL, ( void * ) trans ); + _itemReturn(var); + _itemRelease(var); +} + + +HB_FUNC(FBCOMMIT) +{ + isc_tr_handle trans = NULL; + long status[MAX_FIELDS]; + + trans = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + + if (isc_commit_transaction(status, &trans)) + ERREXIT(status); + + trans = NULL; + _retnl(1); +} + +HB_FUNC(FBROLLBACK) +{ + isc_tr_handle trans = NULL; + long status[MAX_FIELDS]; + + trans = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + + if (isc_rollback_transaction(status, &trans)) + ERREXIT(status); + + trans = NULL; + _retnl(1); +} + + +HB_FUNC(FBEXECUTE) +{ + isc_db_handle db = NULL; + isc_tr_handle trans = NULL; + char *exec_str; + long status[20]; + long status_rollback[20]; + int dialect; + + db = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + exec_str = hb_parcx(2); + dialect = hb_parni(3); + + if (hb_parinfo(4)) { + trans = (isc_tr_handle) hb_itemGetPtr( hb_param( 4, HB_IT_POINTER ) ); + } else { + if ( isc_start_transaction ( status, &trans, 1, &db, 0, NULL ) ) + ERREXIT(status); + } + + if (isc_dsql_execute_immediate(status, &db, &trans, 0, exec_str, dialect, NULL)) { + if (! hb_parinfo(4)) + isc_rollback_transaction ( status_rollback, &trans ); + + ERREXIT(status); + } + + if (!hb_parinfo(4)) + if ( isc_commit_transaction ( status, &trans ) ) + ERREXIT(status); + + _retnl(1); +} + +HB_FUNC(FBQUERY) +{ + isc_db_handle db = NULL; + isc_tr_handle trans = NULL; + ISC_STATUS status[MAX_FIELDS]; + XSQLDA ISC_FAR * sqlda; + isc_stmt_handle stmt = NULL; + XSQLVAR *var; + + char sel_str[MAX_LEN]; + int dialect; + int n, i, dtype; + int num_cols; + + ITEM qry_handle; + ITEM temp; + ITEM aTemp; + ITEM aNew; + + ITEM itemSqlname; + ITEM itemSqltype; + ITEM itemSqllen ; + ITEM itemSqlscale; + ITEM itemRelname; + + db = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + strcpy(sel_str, hb_parcx(2)); + + if (hb_parinfo(3)) { + dialect = hb_parni(3); + } else { + dialect = DIALECT; + } + + if (hb_parinfo(4)) { + trans = (isc_tr_handle) hb_itemGetPtr( hb_param( 4, HB_IT_POINTER ) ); + + } else if ( isc_start_transaction ( status, &trans, 1, &db, 0, NULL ) ) + ERREXIT(status); + + // Allocate an output SQLDA. Just to check number of columns + sqlda = ( XSQLDA * ) hb_xgrab( XSQLDA_LENGTH ( 1 ) ); + sqlda->sqln = 1; + sqlda->version = 1; + + // Allocate a statement + if (isc_dsql_allocate_statement(status, &db, &stmt)) + ERREXIT(status); + + // Prepare the statement. + if (isc_dsql_prepare(status, &trans, &stmt, 0, sel_str, dialect, sqlda)) + ERREXIT(status); + + // Describe sql contents + if (isc_dsql_describe(status, &stmt, dialect, sqlda)) + ERREXIT(status); + + num_cols = sqlda->sqld; + aNew = _itemArrayNew( num_cols ); + + // Relocate necessary number of columns + if ( sqlda->sqld > sqlda->sqln ) { + hb_xfree( sqlda ); + n = sqlda->sqld; + sqlda = ( XSQLDA * ) hb_xgrab( XSQLDA_LENGTH ( n ) ); + sqlda->sqln = n; + sqlda->version = 1; + + if (isc_dsql_describe(status, &stmt, dialect, sqlda)) + ERREXIT(status); + } + + for ( i = 0, var = sqlda->sqlvar; i < sqlda->sqld; i++, var++ ) { + 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 ) ); + } + + aTemp = _itemArrayNew( 5 ); + + itemSqlname = _itemPutC( NULL, sqlda->sqlvar[i].sqlname ); + _itemArrayPut( aTemp, 1, itemSqlname ); + + itemSqltype = _itemPutNL( NULL, (long)dtype ); + _itemArrayPut( aTemp, 2, itemSqltype ); + + itemSqllen = _itemPutNL( NULL, sqlda->sqlvar[i].sqllen ); + _itemArrayPut( aTemp, 3, itemSqllen ); + + itemSqlscale = _itemPutNL( NULL, sqlda->sqlvar[i].sqlscale ); + _itemArrayPut( aTemp, 4, itemSqlscale ); + + itemRelname = _itemPutC( NULL, sqlda->sqlvar[i].relname ); + _itemArrayPut( aTemp, 5, itemRelname ); + + _itemRelease( itemSqlname ); + _itemRelease( itemSqltype ); + _itemRelease( itemSqllen ); + _itemRelease( itemSqlscale ); + _itemRelease( itemRelname ); + + _itemArrayPut( aNew, i+1, aTemp ); + _itemRelease( aTemp ); + } + + if ( !sqlda->sqld ) { + // Execute and commit non-select querys + if ( isc_dsql_execute ( status, &trans, &stmt, dialect, NULL ) ) + ERREXIT(status); + + } else { + if ( isc_dsql_execute ( status, &trans, &stmt, dialect, sqlda ) ) + ERREXIT(status); + } + + qry_handle = _itemArrayNew(6); + + temp = hb_itemPutPtr( NULL, ( void * ) stmt ); + hb_arraySet(qry_handle, 1, temp); + _itemRelease(temp); + + temp = hb_itemPutPtr( NULL, ( void * ) sqlda ); + hb_arraySet(qry_handle, 2, temp); + _itemRelease(temp); + + if (! hb_parinfo(4)) + { + temp = hb_itemPutPtr( NULL, ( void * ) trans ); + hb_arraySet(qry_handle, 3, temp); + _itemRelease(temp); + } + + temp = _itemPutNL(NULL, (long) num_cols); + hb_arraySet(qry_handle, 4, temp); + _itemRelease(temp); + + temp = _itemPutNL(NULL, (long) dialect); + hb_arraySet(qry_handle, 5, temp); + _itemRelease(temp); + + hb_arraySet(qry_handle, 6, aNew); + + _itemReturn(qry_handle); + _itemRelease(qry_handle); + _itemRelease(aNew); +} + + +HB_FUNC(FBFETCH) +{ + isc_stmt_handle stmt = NULL; + ISC_STATUS status[MAX_FIELDS]; + XSQLDA ISC_FAR * sqlda; + long fetch_stat; + int dialect; + + PHB_ITEM aParam ; + + if (ISARRAY( 1 ) ) + { + aParam = hb_param(1,HB_IT_ARRAY); + + stmt = ( isc_stmt_handle ) hb_itemGetPtr(hb_itemArrayGet( aParam, 1 )); + sqlda = ( XSQLDA ISC_FAR * ) hb_itemGetPtr(hb_itemArrayGet( aParam, 2 )); + dialect = hb_itemGetNI(hb_itemArrayGet( aParam, 5 )); + + fetch_stat = isc_dsql_fetch(status, &stmt, dialect, sqlda); + + if (fetch_stat != 100L) + ERREXIT(status); + + } + _retnl(fetch_stat); +} + + +HB_FUNC(FBFREE) +{ + isc_stmt_handle stmt = NULL; + isc_tr_handle trans = NULL; + ISC_STATUS status[MAX_FIELDS]; + XSQLDA ISC_FAR * sqlda; + + PHB_ITEM aParam ; + + if (ISARRAY( 1 ) ) + { + aParam = hb_param(1,HB_IT_ARRAY); + + stmt = ( isc_stmt_handle ) hb_itemGetPtr(hb_itemArrayGet( aParam, 1 )); + sqlda = ( XSQLDA ISC_FAR * ) hb_itemGetPtr(hb_itemArrayGet( aParam, 2 )); + trans = ( isc_tr_handle ) hb_itemGetPtr( hb_itemArrayGet( aParam, 3 )); + + if (isc_dsql_free_statement(status, &stmt, DSQL_drop)) + ERREXIT(status); + + if (trans) + if (isc_commit_transaction(status, &trans)) + ERREXIT(status); + + if ( sqlda ) + hb_xfree( sqlda ); + + _retnl(1); + } + else + _retnl(0); + +} + + +HB_FUNC(FBGETDATA) +{ + int pos; + short dtype; + char data[MAX_BUFFER], *p; + char date_s[25]; + + struct tm times; + XSQLVAR *var; + XSQLDA ISC_FAR * sqlda; + ISC_STATUS status[MAX_FIELDS]; + ISC_QUAD *blob_id; + + PHB_ITEM aParam ; + PHB_ITEM temp; + + aParam = hb_param(1,HB_IT_ARRAY); + + sqlda = ( XSQLDA ISC_FAR * ) hb_itemGetPtr(hb_itemArrayGet( aParam, 2 )); + pos = (int) hb_parnl(2); + + pos--; + + if ( ( pos + 1 ) > sqlda->sqln ) + ERREXIT(status); + + var = sqlda->sqlvar; + + var += pos; + + dtype = var->sqltype & ~1; + p = data; + + if ( ( var->sqltype & 1 ) && ( *var->sqlind < 0 ) ) { + /* null field */ + _ret(); + + } else { + switch ( dtype ) { + case SQL_TEXT: + case SQL_VARYING: + _retclen( var->sqldata, var->sqllen ); + break; + + case SQL_TIMESTAMP: + isc_decode_timestamp ( ( ISC_TIMESTAMP ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%04d-%02d-%02d %02d:%02d:%02d.%04lu", + times.tm_year + 1900, + times.tm_mon + 1, + times.tm_mday, + times.tm_hour, + times.tm_min, + times.tm_sec, + ( ( ISC_TIMESTAMP * ) var->sqldata )->timestamp_time % 10000 ); + sprintf ( p, "%*s ", 24, date_s ); + + _retc(p); + break; + + case SQL_TYPE_DATE: + isc_decode_sql_date ( ( ISC_DATE ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%04d-%02d-%02d", times.tm_year + 1900, times.tm_mon + 1, times.tm_mday ); + sprintf ( p, "%*s ", 8, date_s ); + + _retc(p); + break; + + case SQL_TYPE_TIME: + isc_decode_sql_time ( ( ISC_TIME ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%02d:%02d:%02d.%04lu", + times.tm_hour, + times.tm_min, + times.tm_sec, ( *( ( ISC_TIME * ) var->sqldata ) ) % 10000 ); + sprintf ( p, "%*s ", 13, date_s ); + + _retc(p); + break; + + case SQL_BLOB: + + blob_id = ( ISC_QUAD * ) var->sqldata; + + temp = hb_itemPutPtr( NULL, ( void * ) blob_id ); + _itemReturn(temp); + _itemRelease(temp); + + 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 ISC_FAR *) var->sqldata; + field_width = 6; + break; + + case SQL_LONG: + value = (ISC_INT64) *(long ISC_FAR *) var->sqldata; + field_width = 11; + break; + + case SQL_INT64: + value = (ISC_INT64) *(ISC_INT64 ISC_FAR *) var->sqldata; + field_width = 21; + break; + } + + dscale = var->sqlscale; + + if (dscale < 0) + { + ISC_INT64 tens; + short i; + + tens = 1; + for (i = 0; i > dscale; i--) + tens *= 10; + + if (value >= 0) + sprintf (p, "%*" 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) + sprintf (p, "%*" ISC_INT64_FORMAT "d.%0*" ISC_INT64_FORMAT "d", + field_width - 1 + dscale, + (ISC_INT64) (value / tens), + -dscale, + (ISC_INT64) -(value % tens)); + + else + sprintf (p, "%*s.%0*" ISC_INT64_FORMAT "d", + field_width - 1 + dscale, + "-0", + -dscale, + (ISC_INT64) -(value % tens)); + } + else if (dscale) + sprintf (p, "%*" ISC_INT64_FORMAT "d%0*d", field_width, (ISC_INT64) value, dscale, 0); + else + sprintf (p, "%*" ISC_INT64_FORMAT "d", field_width, (ISC_INT64) value); + }; + _retc(p); + break; + + case SQL_FLOAT: + sprintf(p, "%15g ", *(float ISC_FAR *) (var->sqldata)); + _retc(p); + break; + + case SQL_DOUBLE: + sprintf(p, "%24f ", *(double ISC_FAR *) (var->sqldata)); + _retc(p); + break; + + default: + _ret(); + break; + } + } +} + + +HB_FUNC(FBGETBLOB) +{ + ISC_STATUS status[MAX_FIELDS]; + isc_db_handle db = NULL; + isc_tr_handle trans = NULL; + isc_blob_handle blob_handle = NULL; + short blob_seg_len; + char *blob_segment; + ISC_QUAD *blob_id; + char p[MAX_BUFFER]; + long blob_stat; + + ITEM temp; + ITEM aNew; + + db = ( isc_db_handle ) hb_itemGetPtr( hb_param( 1, HB_IT_POINTER ) ); + blob_id = ( ISC_QUAD * ) hb_itemGetPtr( hb_param( 2, HB_IT_POINTER ) ); + + if (_parinfo(3)) { + trans = (isc_tr_handle) hb_itemGetPtr( hb_param( 3, HB_IT_POINTER ) ); + } else { + if ( isc_start_transaction ( status, &trans, 1, &db, 0, NULL ) ) { + ERREXIT(status); + } + } + + if (isc_open_blob2(status, &db, &trans, &blob_handle, blob_id, 0, NULL)) + ERREXIT(status); + + // Get blob segments and their lengths and print each segment. + blob_stat = isc_get_segment(status, &blob_handle, + (unsigned short ISC_FAR *) &blob_seg_len, + sizeof(blob_segment), blob_segment); + + if (blob_stat == 0 || status[1] == isc_segment) + aNew = _itemArrayNew( 0 ); + + while (blob_stat == 0 || status[1] == isc_segment) + { + //p = ( char * ) hb_xgrab( blob_seg_len + 1 ); + sprintf( p, "%*.*s", blob_seg_len, blob_seg_len, blob_segment); + + temp = _itemPutC( NULL, p ); + hb_arrayAdd( aNew, temp ) ; + _itemRelease(temp); + + //hb_xfree(p); + blob_stat = isc_get_segment(status, &blob_handle, + (unsigned short ISC_FAR *)&blob_seg_len, + sizeof(blob_segment), blob_segment); + } + + if (isc_close_blob(status, &blob_handle)) { + _itemRelease(aNew); + ERREXIT(status); + } + + if (!_parinfo(3)) + if ( isc_commit_transaction ( status, &trans ) ) + ERREXIT(status); + + _itemReturn(aNew); + _itemRelease(aNew); +} diff --git a/harbour/contrib/firebird/make_b32.bat b/harbour/contrib/firebird/make_b32.bat new file mode 100644 index 0000000000..06fe3c275f --- /dev/null +++ b/harbour/contrib/firebird/make_b32.bat @@ -0,0 +1,78 @@ +@echo off +rem +rem $Id: make_b32.bat 7974 2007-11-14 23:24:27Z vszakats $ +rem + +rem --------------------------------------------------------------- +rem IMPORTANT: You'll need Firebird headers and this envvar +rem to be set to successfully build this library: +rem set FBDIR=C:\Firebird +rem --------------------------------------------------------------- + +rem --------------------------------------------------------------- +rem This is a generic template file, if it doesn't fit your own needs +rem please DON'T MODIFY IT. +rem +rem Instead, make a local copy and modify that one, or make a call to +rem this batch file from your customized one. [vszakats] +rem +rem Set any of the below settings to customize your build process: +rem set HB_MAKE_PROGRAM= +rem set HB_MAKE_FLAGS= +rem --------------------------------------------------------------- + +if "%HB_DLL_DIR%" == "" set HB_DLL_DIR=%SystemRoot%\system32 +if "%HB_CC_NAME%" == "" set HB_CC_NAME=b32 +if "%HB_MAKE_PROGRAM%" == "" set HB_MAKE_PROGRAM=make.exe +set HB_MAKEFILE=..\mtpl_%HB_CC_NAME%.mak + +set C_USR=%C_USR% -I%FBDIR%\include -DHB_OS_WIN_32_USED + +rem --------------------------------------------------------------- + +rem Save the user value, force silent file overwrite with COPY +rem (not all Windows versions support the COPY /Y flag) +set HB_ORGENV_COPYCMD=%COPYCMD% +set COPYCMD=/Y + +rem --------------------------------------------------------------- + +if "%1" == "clean" goto CLEAN +if "%1" == "CLEAN" goto CLEAN + +if "%1" == "install" goto INSTALL +if "%1" == "INSTALL" goto INSTALL + +:BUILD + + implib ..\..\lib\%HB_CC_NAME%\fbclient.lib %FBDIR%\bin\fbclient.dll + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% %1 %2 %3 > make_%HB_CC_NAME%.log + if errorlevel 1 notepad make_%HB_CC_NAME%.log + goto EXIT + +:CLEAN + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% CLEAN > make_%HB_CC_NAME%.log + if exist make_%HB_CC_NAME%.log del make_%HB_CC_NAME%.log > nul + if exist inst_%HB_CC_NAME%.log del inst_%HB_CC_NAME%.log > nul + goto EXIT + +:INSTALL + + set _HB_INSTALL_PREFIX=%HB_INSTALL_PREFIX% + if "%_HB_INSTALL_PREFIX%" == "" set _HB_INSTALL_PREFIX=..\.. + set _HB_LIB_INSTALL=%HB_LIB_INSTALL% + if "%_HB_LIB_INSTALL%" == "" set _HB_LIB_INSTALL=%_HB_INSTALL_PREFIX%\lib + + copy ..\..\lib\%HB_CC_NAME%\fbclient.lib %_HB_LIB_INSTALL% + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% INSTALL > nul + goto EXIT + +:EXIT + +rem --------------------------------------------------------------- + +rem Restore user value +set COPYCMD=%HB_ORGENV_COPYCMD% diff --git a/harbour/contrib/firebird/make_vc.bat b/harbour/contrib/firebird/make_vc.bat new file mode 100644 index 0000000000..fc284ef86e --- /dev/null +++ b/harbour/contrib/firebird/make_vc.bat @@ -0,0 +1,94 @@ +@echo off +rem +rem $Id: make_vc.bat 7974 2007-11-14 23:24:27Z vszakats $ +rem + +rem --------------------------------------------------------------- +rem IMPORTANT: You'll need Firebird headers and this envvar +rem to be set to successfully build this library: +rem set FBDIR=C:\Firebird +rem --------------------------------------------------------------- + +rem --------------------------------------------------------------- +rem This is a generic template file, if it doesn't fit your own needs +rem please DON'T MODIFY IT. +rem +rem Instead, make a local copy and modify that one, or make a call to +rem this batch file from your customized one. [vszakats] +rem +rem Set any of the below settings to customize your build process: +rem set HB_MAKE_PROGRAM= +rem set HB_MAKE_FLAGS= +rem --------------------------------------------------------------- + +if "%HB_DLL_DIR%" == "" set HB_DLL_DIR=%SystemRoot%\system32 +if "%HB_CC_NAME%" == "" set HB_CC_NAME=vc +if "%HB_MAKE_PROGRAM%" == "" set HB_MAKE_PROGRAM=nmake.exe +set HB_MAKEFILE=..\mtpl_%HB_CC_NAME%.mak + +set C_USR=%C_USR% -I%FBDIR%\include -DHB_OS_WIN_32_USED + +rem --------------------------------------------------------------- + +rem Save the user value, force silent file overwrite with COPY +rem (not all Windows versions support the COPY /Y flag) +set HB_ORGENV_COPYCMD=%COPYCMD% +set COPYCMD=/Y + +rem --------------------------------------------------------------- + +if "%1" == "clean" goto CLEAN +if "%1" == "CLEAN" goto CLEAN + +if "%1" == "install" goto INSTALL +if "%1" == "INSTALL" goto INSTALL + +:BUILD + + rem --------------------------------------------------------------- + rem This .dll to .lib conversion needs GNU sed.exe in the path + rem --------------------------------------------------------------- + echo./[ \t]*ordinal hint/,/^^[ \t]*Summary/{> _temp.sed + echo. /^^[ \t]\+[0-9]\+/{>> _temp.sed + echo. s/^^[ \t]\+[0-9]\+[ \t]\+[0-9A-Fa-f]\+[ \t]\+[0-9A-Fa-f]\+[ \t]\+\(.*\)/\1/p>> _temp.sed + echo. }>> _temp.sed + echo.}>> _temp.sed + DUMPBIN /EXPORTS %FBDIR%\bin\fbclient.dll > _dump.tmp + echo.LIBRARY %FBDIR%\bin\fbclient.dll > _temp.def + echo.EXPORTS >> _temp.def + sed -nf _temp.sed < _dump.tmp >> _temp.def + LIB /MACHINE:X86 /DEF:_temp.def /OUT:..\..\lib\%HB_CC_NAME%\fbclient.lib + del _dump.tmp + del _temp.def + del _temp.sed + rem --------------------------------------------------------------- + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% %1 %2 %3 > make_%HB_CC_NAME%.log + if errorlevel 1 notepad make_%HB_CC_NAME%.log + goto EXIT + +:CLEAN + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% CLEAN > make_%HB_CC_NAME%.log + if exist make_%HB_CC_NAME%.log del make_%HB_CC_NAME%.log > nul + if exist inst_%HB_CC_NAME%.log del inst_%HB_CC_NAME%.log > nul + goto EXIT + +:INSTALL + + set _HB_INSTALL_PREFIX=%HB_INSTALL_PREFIX% + if "%_HB_INSTALL_PREFIX%" == "" set _HB_INSTALL_PREFIX=..\.. + set _HB_LIB_INSTALL=%HB_LIB_INSTALL% + if "%_HB_LIB_INSTALL%" == "" set _HB_LIB_INSTALL=%_HB_INSTALL_PREFIX%\lib + + copy ..\..\lib\%HB_CC_NAME%\fbclient.lib %_HB_LIB_INSTALL% + + %HB_MAKE_PROGRAM% %HB_MAKE_FLAGS% -f %HB_MAKEFILE% INSTALL > nul + goto EXIT + +:EXIT + +rem --------------------------------------------------------------- + +rem Restore user value +set COPYCMD=%HB_ORGENV_COPYCMD% diff --git a/harbour/contrib/firebird/readme.txt b/harbour/contrib/firebird/readme.txt new file mode 100644 index 0000000000..2d51f01eae --- /dev/null +++ b/harbour/contrib/firebird/readme.txt @@ -0,0 +1,55 @@ + +README 23/12/2003 - Harbour Low Level api for Firebird and Interbase RDBMS + +This work is not finished yet. It's to be seem like Harbour TMysql routines. + +To use with bcc, you need import library, ex: implib fbclient.lib fbclient.dll or implib gds32.lib gds32.dll. +On Linux you will need link fbclient.so, this can be found usually at /usr/lib. + +For full firebird documentation look at: + +Firebird home: http://firebird.sourceforge.net/index.php +Api: http://www.ibphoenix.com/downloads/60ApiGuide.zip +Data Definition: http://www.ibphoenix.com/downloads/60DataDef.zip +Language Reference: http://www.ibphoenix.com/downloads/60LangRef.zip +Developers guide: http://www.ibphoenix.com/downloads/60DevGuide.zip + +The Class implementation has no all implementation like TMysql has, because Firebird it's diferent. +For example, you can't navigate in records like Mysql do, ex: Getrow( number of row ), in firebird you can +just go forward. + +You will need ibase.h, it can be found at firebird/include + +FILES: + +firebird.c - Low level api +TFirebird.prg - Class implementation, it's to be seems like TMysql. + +tests\simple.prg - Simple test class +tests\stress.prg - Stress test class +tests\test.prg - Testing using only low level api +tests\test.c - Pure C code to test firebird access. + +TODO: + +Full implementation of blob control. For now, we have only partial control, only for text blobs (sybtype 1). +Improve Insert and Update commands using DSQL. + +Implements to do: +FBOpenBlob( blob_id ) +FBReadBlob(blob_id, string, segment_size) + +FBCreateBlob() +FBPutBlob(blob_id, string, segment_size) + +FBCloseBlob( blob_id ) + + +BUGS: + +Fix a few windows gpf and linux segment fault. I Need some help to find what's going on here. + + +That's all folks and sorry my poor english + +Rodrigo Moreno - rodrigo_moreno@yahoo.com \ No newline at end of file diff --git a/harbour/contrib/firebird/test/Makefile b/harbour/contrib/firebird/test/Makefile new file mode 100644 index 0000000000..a480da9c1c --- /dev/null +++ b/harbour/contrib/firebird/test/Makefile @@ -0,0 +1,32 @@ +# +# $Id: Makefile,v 1.1 2003/12/31 00:24:35 lculik Exp $ +# + +ifeq ($(HB_MAIN),) + HB_MAIN = std +endif + +ROOT = ../../../ + +CONTRIBS=\ + firebird \ + +PRG_SOURCES=\ + simple.prg \ + +PRG_MAIN=\ + simple.prg + +LIBS=\ + debug \ + vm \ + rtl \ + lang \ + rdd \ + rtl \ + vm \ + macro \ + common \ + fbclient \ + +include $(TOP)$(ROOT)config/bin.cf diff --git a/harbour/contrib/firebird/test/bld_b32.bat b/harbour/contrib/firebird/test/bld_b32.bat new file mode 100644 index 0000000000..4375049cb3 --- /dev/null +++ b/harbour/contrib/firebird/test/bld_b32.bat @@ -0,0 +1,80 @@ +@echo off +rem +rem $Id: bld_b32.bat 7941 2007-11-11 01:42:42Z vszakats $ +rem + +if A%1 == A GOTO :SYNTAX +if NOT EXIST %1.prg GOTO :NOEXIST + +ECHO Build: Compiling... + +set hdir=..\..\.. + +%hdir%\bin\harbour %1 /w /n /i..\include;%hdir%\include %2 %3 > bld_b32.log +type bld_b32.log +IF ERRORLEVEL 1 PAUSE +IF ERRORLEVEL 1 GOTO EXIT + +echo -O2 -e%1.exe -I%hdir%\include %1.c > bld_b32.mak +bcc32 -M -c @bld_b32.mak +:ENDCOMPILE + +echo c0w32.obj + > bld_b32.mak +echo %1.obj, + >> bld_b32.mak +echo %1.exe, + >> bld_b32.mak +echo %1.map, + >> bld_b32.mak +echo %hdir%\lib\rtl.lib + >> bld_b32.mak +echo %hdir%\lib\vm.lib + >> bld_b32.mak +echo %hdir%\lib\gtwin.lib + >> bld_b32.mak +echo %hdir%\lib\lang.lib + >> bld_b32.mak +echo %hdir%\lib\macro.lib + >> bld_b32.mak +echo %hdir%\lib\rdd.lib + >> bld_b32.mak +echo %hdir%\lib\dbfntx.lib + >> bld_b32.mak +echo %hdir%\lib\dbfcdx.lib + >> bld_b32.mak +echo %hdir%\lib\debug.lib + >> bld_b32.mak +echo %hdir%\lib\common.lib + >> bld_b32.mak +echo %hdir%\lib\pp.lib + >> bld_b32.mak +echo %hdir%\lib\hbsix.lib + >> bld_b32.mak +echo %hdir%\lib\dbffpt.lib + >> bld_b32.mak +echo %hdir%\lib\fbclient.lib + >> bld_b32.mak +echo %hdir%\lib\firebird.lib + >> bld_b32.mak + +rem Uncomment these two lines to use Advantage RDD +rem echo %hdir%\lib\rddads.lib + >> bld_b32.mak +rem echo %hdir%\lib\ace32.lib + >> bld_b32.mak + +echo cw32.lib + >> bld_b32.mak +echo import32.lib, >> bld_b32.mak + +ECHO Build: Linking... +rem Use these flags to avoid the console window creation +rem ilink32 -Gn -aa -Tpe -s @bld_b32.mak +ilink32 -Gn -Tpe -s @bld_b32.mak + +rem delete temporary files +del %1.c +del %1.obj +if exist %1.map del %1.map +if exist %1.tds del %1.tds +del bld_b32.mak +del bld_b32.log + +IF ERRORLEVEL 1 GOTO LINKERROR +ECHO Build: Done. +%1 +GOTO EXIT +ECHO + +:LINKERROR +rem if exist meminfo.txt notepad meminfo.txt +rem PAUSE * Linking errors * +GOTO EXIT + +:SYNTAX +ECHO SYNTAX: bld_b32 [Program] {-- Don't specify .prg extension +GOTO EXIT + +:NOEXIST +ECHO Build: The specified %1.prg does not exist + +:EXIT diff --git a/harbour/contrib/firebird/test/simple.prg b/harbour/contrib/firebird/test/simple.prg new file mode 100644 index 0000000000..1fb60426ee --- /dev/null +++ b/harbour/contrib/firebird/test/simple.prg @@ -0,0 +1,188 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +#include "common.ch" + +Function main() + Local oServer, oQuery, oRow, i, x, aTables, aStruct, aKey + + Local cServer := '192.168.1.33:D:\firebird\test\test.gdb' + Local cUser := 'sysdba' + Local cPass := 'masterkey' + Local nDialect := 1 + Local cQuery + + if File('test.gdb') + FErase('test.gdb') + end + + ? FBCreateDB('test.gdb', cuser, cpass, 1024, 'ASCII', nDialect ) + + ? "Connecting..." + + oServer := TFBServer():New(cServer, cUser, cPass, nDialect) + + if oServer:NetErr() + ? oServer:Error() + quit + end + + ? 'Tables...' + + For x := 1 to 1 + aTables := oServer:ListTables() + + For i := 1 to Len(aTables) + ? aTables[i] + next + Next + + ? 'Using implicit transaction...' + + if oServer:TableExists('TEST') + oServer:Execute('DROP TABLE Test') + oServer:Execute('DROP DOMAIN boolean_field') + end + + ? 'Creating domain for boolean fields...' + oServer:Execute('create domain boolean_field as smallint default 0 not null check (value in (0,1))') + + oServer:StartTransaction() + ? 'Creating test table...' + cQuery := 'CREATE TABLE test(' + cQuery += ' Code SmallInt not null primary key, ' + cQuery += ' dept Integer, ' + cQuery += ' Name Varchar(40), ' + cQuery += ' Sales boolean_field, ' + cQuery += ' Tax Float, ' + cQuery += ' Salary Double Precision, ' + cQuery += ' Budget Numeric(12,2), ' + cQuery += ' Discount Decimal(5,2), ' + cQuery += ' Creation Date, ' + cQuery += ' Description blob sub_type 1 segment size 40 ) ' + + oServer:Execute(cQuery) + + if oServer:neterr() + ? oServer:Error() + end + + oServer:Commit() + + oQuery := oServer:Query('SELECT code, dept, name, sales, salary, creation FROM test') + wait + + + ? 'Structure of test table' + aStruct := oServer:TableStruct('test') + + For i := 1 to Len(aStruct) + ? + For x := 1 to Len(aStruct[i]) + ?? aStruct[i,x] + Next + next + + ? 'Inserting, declared transaction control ' + oServer:StartTransaction() + + For i := 1 to 100 + cQuery := 'INSERT INTO test(code, dept, name, sales, tax, salary, budget, Discount, Creation, Description) ' + cQuery += 'VALUES( ' + str(i) + ', 2, "TEST", 1, 5, 3000, 1500.2, 7.5, "12-22-2003", "Short Description about what ? ")' + + oServer:Execute(cQuery) + + if oServer:neterr() + ? oServer:error() + end + Next + + oServer:Commit() + + oQuery := oServer:Query('SELECT code, name, description, sales FROM test') + + aStruct := oQuery:Struct() + + For i := 1 to Len(aStruct) + ? aStruct[i,1], aStruct[i,2], aStruct[i,3], aStruct[i,4] + 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) + end + + if oQuery:Recno() == 60 + oRow := oQuery:getrow() + ? 'Delete: ', oServer:Delete(oRow) + end + END + + ? '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) + END + + oQuery:Destroy() + + oServer:Destroy() + + + ? "Closing..." + + return nil + + + diff --git a/harbour/contrib/firebird/test/stress.prg b/harbour/contrib/firebird/test/stress.prg new file mode 100644 index 0000000000..2c48342bf0 --- /dev/null +++ b/harbour/contrib/firebird/test/stress.prg @@ -0,0 +1,134 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +/* VERY IMPORTANT: Don't use this querys as sample, they are used for stress tests !!! */ + +Function Main() + Local oServer, oQuery, oRow, i, x + + Local cServer := '192.168.1.33:D:\firebird\test\test2.gdb' + Local cUser := 'sysdba' + Local cPass := 'masterkey' + Local nDialect := 1 + Local cQuery + + CLEAR SCREEN + + if ! File('test2.gdb') .and. .F. + ? FBCreateDB('test2.gdb', cuser, cpass, 1024, 'WIN1251', nDialect ) + end + + ? "Connecting..." + + oServer := TFBServer():New(cServer, cUser, cPass, nDialect) + + if oServer:NetErr() + ? oServer:Error() + quit + end + + if oServer:TableExists('test') + ? oServer:Execute('DROP TABLE Test') + ? oServer:Execute('DROP DOMAIN boolean_field') + end + + ? '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...' + cQuery := 'CREATE TABLE test(' + cQuery += ' Code SmallInt not null primary key, ' + cQuery += ' dept Integer, ' + cQuery += ' Name Varchar(40), ' + cQuery += ' Sales boolean_field, ' + cQuery += ' Tax Float, ' + cQuery += ' Salary Double Precision, ' + cQuery += ' Budget Numeric(12,2), ' + cQuery += ' Discount Decimal(5,2), ' + cQuery += ' Creation Date, ' + cQuery += ' Description blob sub_type 1 segment size 40 ) ' + + ? oServer:Execute(cQuery) + +quit + + oQuery := oServer:Query('SELECT code, dept, name, sales, salary, creation FROM test') + + oServer:StartTransaction() + + For i := 1 to 10000 + @ 15,0 say 'Inserting values....' + str(i) + + oRow := oQuery:Blank() + + oRow:Fieldput(1, i) + oRow:Fieldput(2, i+1) + oRow:Fieldput(3, 'DEPARTMENT NAME ' + strzero(i) ) + oRow:Fieldput(4, (mod(i,10) == 0) ) + oRow:Fieldput(5, 3000 + i ) + oRow:fieldput(6, Date() ) + + oServer:Append(oRow) + + if mod(i,100) == 0 + oServer:Commit() + oServer:StartTransaction() + end + Next + + For i := 5000 to 7000 + @ 16,0 say 'Deleting values....' + str(i) + + oRow := oQuery:Blank() + oServer:Delete(oRow, 'code = ' + str(i)) + + if mod(i,100) == 0 + oServer:Commit() + oServer:StartTransaction() + end + Next + + For i := 2000 to 3000 + @ 17,0 say 'Updating values....' + str(i) + + oRow := oQuery:Blank() + oRow:Fieldput(5, 4000+i) + oServer:update(oRow, 'code = ' + str(i)) + + if mod(i,100) == 0 + oServer:Commit() + oServer:StartTransaction() + end + Next + + oQuery := oServer:Query('SELECT sum(salary) sum_salary FROM test WHERE code between 1 and 4000') + + if ! oQuery:Neterr() + oQuery:Fetch() + @ 18,0 say 'Sum values....' + Str(oQuery:Fieldget(1)) + oQuery:Destroy() + end + + + x := 0 + For i := 1 to 4000 + oQuery := oServer:Query('SELECT * FROM test WHERE code = ' + str(i)) + + if ! oQuery:Neterr() + oQuery:Fetch() + oRow := oQuery:getrow() + + oQuery:destroy() + x += oRow:fieldget(oRow:fieldpos('salary')) + + @ 19,0 say 'Sum values....' + str(x) + end + Next + + + oServer:Destroy() + + ? "Closing..." +return nil diff --git a/harbour/contrib/firebird/test/test.prg b/harbour/contrib/firebird/test/test.prg new file mode 100644 index 0000000000..df803ac5c8 --- /dev/null +++ b/harbour/contrib/firebird/test/test.prg @@ -0,0 +1,77 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +#include "common.ch" + +Function Main() + + nDialect := 1 + + if File('test.gdb') + FErase('test.gdb') + end + + ? FBCreateDB('test.gdb','sysdba', 'masterkey', 1024, 'ASCII', nDialect ) + + + /* Connect rdbms */ + db := FBConnect("127.0.0.1:d:\firebird\test\test.gdb", "sysdba", "masterkey") + + if ISNUMBER(db) + ? 'Error' + quit + end + + ? FBExecute(db, 'sldjfs;ldjs;djf', dialect) + + ? FBClose(db) + + trans := FBStartTransaction(db) + qry := FBQuery(db, 'create table teste (code smallint)', dialect, trans) + FBCommit(trans) + + + ? "Status Execute: ", FBExecute( db, 'insert into customer(customer) values ("test 1")', dialect, trans) + + ? "Status no Rollback: ", FBRollback(trans) + + trans := FBStartTransaction(db) + ? "Status Execute: ", FBExecute( db, 'insert into customer(customer) values ("test 2")', dialect, trans ) + ? "Status commit: ", FBCommit(trans) + + + ? "Status Execute: ", FBExecute( db, 'insert into customer(customer) values ("test 3")', dialect ) + + // FIX WINDOWS GPF BELOW + + qry := FBQuery(db, "SELECT * FROM sales", dialect) + + num_cols := qry[4] + columns := qry[6] + + For x := 1 to num_cols + ? x, "> " + For y := 1 to len(columns[x]) + ?? columns[x,y], ' ' + Next + Next + + ? '---' + + do while (fetch_stat := FBFetch(qry)) == 0 + ? fetch_stat + for x := 1 to num_cols + ?? FBGetData(qry,x), ', ' + next + end + + ? 'Fetch code:', fetch_stat + + ? "Status Free sql: ", FBFree(qry) + + + /* Close connection with rdbms */ + ? "Status Fechar Database: ", FBClose(db) + + Return Nil diff --git a/harbour/contrib/firebird/test/testapi.c b/harbour/contrib/firebird/test/testapi.c new file mode 100644 index 0000000000..f6656a2813 --- /dev/null +++ b/harbour/contrib/firebird/test/testapi.c @@ -0,0 +1,403 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +#include +#include +#include +#include +#include +#include + +#ifndef ISC_INT64_FORMAT + +#if (defined(_MSC_VER) && defined(WIN32)) || (defined(__BORLANDC__) && defined(__WIN32__)) +#define ISC_INT64_FORMAT "I64" +#else +#define ISC_INT64_FORMAT "ll" +#endif +#endif + +#define USER "sysdba" +#define PASSWORD "masterkey" +#define DATABASE "192.168.1.33:d:\\fontes\\lixo\\test.gdb" +#define ERREXIT(status, rc) {isc_print_status(status); return rc;} +#define MAX_BUFFER 1024 + +int execute( char *exec_str ); +int query( char *sel_str ); +int fetch( void ); +int qclose( void ); +char *getdata(int pos); + + +isc_db_handle db = NULL; +int dialect = 1; +XSQLDA ISC_FAR * sqlda; +isc_stmt_handle stmt = NULL; +isc_tr_handle trans = NULL; + +int main () +{ + char dpb[48]; + int i = 0, len; + long status[20]; + + dpb[i++] = isc_dpb_version1; + + dpb[i++] = isc_dpb_user_name; + len = strlen(USER); + dpb[i++] = (char) len; + strncpy(&(dpb[i]), USER, len); + i += len; + + dpb[i++] = isc_dpb_password; + len = strlen (PASSWORD); + dpb[i++] = len; + strncpy(&(dpb[i]), PASSWORD, len); + i += len; + + if (isc_attach_database(status, 0, DATABASE, &db, i, dpb)) + ERREXIT(status, 1); + + execute("DROP TABLE TESTE"); + + execute("CREATE TABLE TESTE (code smallint)"); + + execute("INSERT INTO TESTE (code) VALUES (100)"); + + query("SELECT * FROM TESTE"); + while (fetch() == 0) + printf("%s\n", getdata(0)); + qclose(); + + + if (isc_detach_database(status, &db)) + ERREXIT(status, 1); + + return 1; +} + +int execute( char *exec_str ) +{ + isc_tr_handle trans = NULL; + long status[20]; + + if (isc_start_transaction(status, &trans, 1, &db, 0, NULL)) + ERREXIT(status, 1); + + if (isc_dsql_execute_immediate(status, &db, &trans, 0, exec_str, dialect, NULL)) + ERREXIT(status, 1); + + if (isc_commit_transaction(status, &trans)) + ERREXIT(status, 1); + + return 1; +} + +int query( char *sel_str ) +{ + ISC_STATUS status[20]; + XSQLVAR *var; + + int n, i, dtype; + + if ( isc_start_transaction ( status, &trans, 1, &db, 0, NULL ) ) + ERREXIT(status, 1); + + // Allocate an output SQLDA. Just to check number of columns + sqlda = ( XSQLDA * ) malloc( XSQLDA_LENGTH ( 1 ) ); + sqlda->sqln = 1; + sqlda->version = 1; + + // Allocate a statement + if (isc_dsql_allocate_statement(status, &db, &stmt)) + ERREXIT(status, 1); + + // Prepare the statement. + if (isc_dsql_prepare(status, &trans, &stmt, 0, sel_str, dialect, sqlda)) + ERREXIT(status, 1); + + // Describe sql contents + if (isc_dsql_describe(status, &stmt, dialect, sqlda)) + ERREXIT(status, 1); + + // Relocate necessary number of columns + if ( sqlda->sqld > sqlda->sqln ) { + free( sqlda ); + n = sqlda->sqld; + sqlda = ( XSQLDA * ) malloc( XSQLDA_LENGTH ( n ) ); + sqlda->sqln = n; + sqlda->version = 1; + + if (isc_dsql_describe(status, &stmt, dialect, sqlda)) + ERREXIT(status, 1); + } + + for ( i = 0, var = sqlda->sqlvar; i < sqlda->sqld; i++, var++ ) { + dtype = ( var->sqltype & ~1 ); + switch ( dtype ) { + case SQL_VARYING: + var->sqltype = SQL_TEXT; + var->sqldata = ( char * ) malloc( sizeof ( char ) * var->sqllen + 2 ); + break; + case SQL_TEXT: + var->sqldata = ( char * ) malloc( sizeof ( char ) * var->sqllen + 2 ); + break; + case SQL_LONG: + var->sqltype = SQL_LONG; + var->sqldata = ( char * ) malloc( sizeof ( long ) ); + break; + default: + var->sqldata = ( char * ) malloc( sizeof ( char ) * var->sqllen ); + break; + } + if ( var->sqltype & 1 ) { + var->sqlind = ( short * ) malloc( sizeof ( short ) ); + } + } + + if ( !sqlda->sqld ) { + // Execute and commit non-select querys + if ( isc_dsql_execute ( status, &trans, &stmt, dialect, NULL ) ) + ERREXIT(status, 1); + + if (isc_commit_transaction(status, &trans)) + ERREXIT(status, 1); + + trans = NULL; + + } else { + if ( isc_dsql_execute ( status, &trans, &stmt, dialect, sqlda ) ) + ERREXIT(status, 1); + } + + return 1; +} + +int fetch( void ) +{ + long fetch_stat; + long status[20]; + + fetch_stat = isc_dsql_fetch(status, &stmt, dialect, sqlda); + + if (fetch_stat != 100L) + ERREXIT(status, 1); + + return fetch_stat; +} + +int qclose( void ) +{ + long status[20]; + + if (isc_dsql_free_statement(status, &stmt, DSQL_drop)) + ERREXIT(status, 1); + + if (trans) + if (isc_commit_transaction(status, &trans)) + ERREXIT(status, 1); + + if ( sqlda ) + free( sqlda ); + + return 1; +} + +char *getdata(int pos) +{ + short dtype; + char data[MAX_BUFFER], *p; + char blob_s[20], date_s[25]; + short len; + long status[20]; + + struct tm times; + ISC_QUAD bid; + XSQLVAR *var; + + if ( ( pos + 1 ) > sqlda->sqln ) + return "error"; + + var = sqlda->sqlvar; + + var += pos; + + dtype = var->sqltype & ~1; + p = data; + + if ( ( var->sqltype & 1 ) && ( *var->sqlind < 0 ) ) { + switch ( dtype ) { + case SQL_TEXT: + case SQL_VARYING: + len = var->sqllen; + break; + case SQL_SHORT: + len = 6; + if ( var->sqlscale > 0 ) + len += var->sqlscale; + break; + case SQL_LONG: + len = 11; + if ( var->sqlscale > 0 ) + len += var->sqlscale; + break; + case SQL_INT64: + len = 21; + if ( var->sqlscale > 0 ) + len += var->sqlscale; + break; + case SQL_FLOAT: + len = 15; + break; + case SQL_DOUBLE: + len = 24; + break; + case SQL_TIMESTAMP: + len = 24; + break; + case SQL_TYPE_DATE: + len = 10; + break; + case SQL_TYPE_TIME: + len = 13; + break; + case SQL_BLOB: + case SQL_ARRAY: + default: + len = 17; + break; + } + if ( ( dtype == SQL_TEXT ) || ( dtype == SQL_VARYING ) ) + sprintf ( p, "%-*s ", len, "NULL" ); + else + sprintf ( p, "%*s ", len, "NULL" ); + } else { + switch ( dtype ) { + case SQL_TEXT: + sprintf ( p, "%.*s ", var->sqllen, var->sqldata ); + break; + + case SQL_VARYING: + sprintf ( p, "%.*s ", var->sqllen, var->sqldata ); + break; + + case SQL_SHORT: + case SQL_LONG: + case SQL_INT64: + { + ISC_INT64 value = 0; + short field_width = 0; + short dscale; + + switch ( dtype ) { + case SQL_SHORT: + value = ( ISC_INT64 ) * ( short ISC_FAR * ) var->sqldata; + field_width = 6; + break; + case SQL_LONG: + value = ( ISC_INT64 ) * ( long ISC_FAR * ) var->sqldata; + field_width = 11; + break; + case SQL_INT64: + value = ( ISC_INT64 ) * ( ISC_INT64 ISC_FAR * ) var->sqldata; + field_width = 21; + break; + } + dscale = var->sqlscale; + if ( dscale < 0 ) { + ISC_INT64 tens; + short i; + + tens = 1; + for ( i = 0; i > dscale; i-- ) { + tens *= 10; + + if ( value >= 0 ) { + + sprintf ( p, + "%*" 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 ) { + + sprintf ( p, + "%*" ISC_INT64_FORMAT "d.%0*" + ISC_INT64_FORMAT "d", + field_width - 1 + dscale, + ( ISC_INT64 ) ( value / tens ), -dscale, + ( ISC_INT64 ) - ( value % tens ) ); + } else { + + sprintf ( p, "%*s.%0*" ISC_INT64_FORMAT "d", + field_width - 1 + dscale, + "-0", -dscale, + ( ISC_INT64 ) - ( value % tens ) ); + } + } + } else if ( dscale ) { + sprintf ( p, "%*" ISC_INT64_FORMAT "d%0*d", + field_width, ( ISC_INT64 ) value, dscale, 0 ); + } else { + sprintf ( p, "%*" ISC_INT64_FORMAT "d", + field_width, ( ISC_INT64 ) value ); + } + }; + break; + + case SQL_FLOAT: + sprintf ( p, "%15g ", *( float ISC_FAR * ) ( var->sqldata ) ); + break; + + case SQL_DOUBLE: + sprintf ( p, "%24f ", *( double ISC_FAR * ) ( var->sqldata ) ); + break; + + case SQL_TIMESTAMP: + isc_decode_timestamp ( ( ISC_TIMESTAMP ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%04d-%02d-%02d %02d:%02d:%02d.%04lui", + times.tm_year + 1900, + times.tm_mon + 1, + times.tm_mday, + times.tm_hour, + times.tm_min, + times.tm_sec, + ( ( ISC_TIMESTAMP * ) var->sqldata )->timestamp_time % 10000 ); + sprintf ( p, "%*s ", 24, date_s ); + break; + + case SQL_TYPE_DATE: + isc_decode_sql_date ( ( ISC_DATE ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%04d-%02d-%02d", + times.tm_year + 1900, times.tm_mon + 1, times.tm_mday ); + sprintf ( p, "%*s ", 10, date_s ); + break; + + case SQL_TYPE_TIME: + isc_decode_sql_time ( ( ISC_TIME ISC_FAR * ) var->sqldata, × ); + sprintf ( date_s, "%02d:%02d:%02d.%04lui", + times.tm_hour, + times.tm_min, + times.tm_sec, ( *( ( ISC_TIME * ) var->sqldata ) ) % 10000 ); + sprintf ( p, "%*s ", 13, date_s ); + break; + + case SQL_BLOB: + case SQL_ARRAY: + /* Print the blob id on blobs or arrays */ + bid = *( ISC_QUAD ISC_FAR * ) var->sqldata; + sprintf ( blob_s, "%08x:%08x", ( unsigned int ) bid.gds_quad_high, + ( unsigned int ) bid.gds_quad_low ); + sprintf ( p, "%17s ", blob_s ); + break; + + default: + break; + } + } + + return ( p ); +} diff --git a/harbour/contrib/firebird/tfirebird.prg b/harbour/contrib/firebird/tfirebird.prg new file mode 100644 index 0000000000..15ba12f7fa --- /dev/null +++ b/harbour/contrib/firebird/tfirebird.prg @@ -0,0 +1,1063 @@ +/* + * $Id: atrepl.c 7583 2007-07-06 21:17:36Z druzus $ + */ + +/* + * xHarbour Project source code: + * Firebird RDBMS low level (client api) interface code. + * + * Copyright 2003 Rodrigo Moreno rodrigo_moreno@yahoo.com + * www - http://www.xharbour.org + * + * 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. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * 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. + * + * See doc/license.txt for licensing terms. + * + */ + +#include "common.ch" +#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 + + +CLASS TFbServer + DATA db + DATA trans + DATA StartedTrans + DATA nError + DATA lError + DATA 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 + + Default nDialect TO 1 + + ::lError := .F. + ::nError := 0 + ::StartedTrans := .F. + ::Dialect := nDialect + + ::db := FBConnect(cServer, cUser, cPassword) + + if ISNUMBER(::db) + ::lError := .T. + ::nError := ::db + end +RETURN self + + +METHOD StartTransaction() CLASS TFbServer + Local result := .F. + + ::trans := FBStartTransaction(::db) + + if ISNUMBER(::trans) + ::lError := .T. + ::nError := ::trans + else + result := .T. + ::lError := .F. + ::lnError := 0 + ::StartedTrans := .T. + end +RETURN result + + +METHOD Rollback() CLASS TFbServer + Local result := .F., n + + if ::StartedTrans + if (n := FBRollback(::trans)) < 0 + ::lError := .T. + ::nError := n + else + ::lError := .F. + ::nError := 0 + result := .T. + ::StartedTrans := .F. + end + end +RETURN result + + +METHOD Commit() CLASS TFbServer + Local result := .F., n + + if ::StartedTrans + if (n := FBCommit(::trans)) < 0 + ::lError := .T. + ::nError := n + else + ::lError := .F. + ::nError := 0 + result := .T. + ::StartedTrans := .F. + end + end +RETURN result + + +METHOD Execute( cQuery ) CLASS TFbServer + Local result, n + + cQuery := RemoveSpaces(cQuery) + + if ::StartedTrans + n := FBExecute( ::db, cQuery, ::dialect, ::trans ) + else + n := FBExecute( ::db, cQuery, ::dialect ) + end + + if n < 0 + ::lError := .T. + ::nError := n + result := .F. + else + ::lError := .F. + ::nError := 0 + result := .T. + end +RETURN result + + +METHOD Query( cQuery ) CLASS TFbServer + Local oQuery + + oQuery := TFbQuery():New(::db, cQuery, ::dialect) +RETURN oQuery + + +METHOD TableExists( cTable ) CLASS TFbServer + Local cQuery, result := .F., qry + + cQuery := 'select rdb$relation_name from rdb$relations where rdb$relation_name = "' + Upper(cTable) + '"' + + qry := FBQuery(::db, cQuery, ::dialect) + + if ISARRAY(qry) + result := (FBFetch(qry) == 0) + + FBFree(qry) + end + +RETURN result + + +METHOD ListTables() CLASS TFbServer + Local result := {}, cQuery, qry, fetch_stmt + + 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 ISARRAY(qry) + do while (fetch_stmt := FBFetch(qry)) == 0 + aadd( result, FBGetdata(qry, 1) ) + end + + FBFree(qry) + end +RETURN result + + +METHOD TableStruct( cTable ) CLASS TFbServer + Local result := {}, cQuery, cType, nSize, cDomain, cField, nType, nDec, fetch_stmt + 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 ISARRAY(qry) + do while (fetch_stmt := 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 + end + + 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 + end + + aadd( result, { cField, cType, nSize, nDec } ) + + end + + FBFree(qry) + end +RETURN result + + +METHOD Delete( oRow, cWhere ) CLASS TFbServer + Local result := .F., aKeys, i, nField, xField, cQuery, aTables + + aTables := oRow:GetTables() + + if ! ISNUMBER(::db) .and. len(aTables) == 1 + // Cannot delete joined tables + + if ISNIL(cWhere) + 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 += ',' + end + Next + end + + if ! (cWhere == '') + cQuery := 'DELETE FROM ' + aTables[1] + ' WHERE ' + cWhere + + result := ::Execute(cQuery) + end + end +RETURN result + + +METHOD Append( oRow ) CLASS TFbServer + Local result := .F., cQuery, i, aTables + + aTables := oRow:GetTables() + + if ! ISNUMBER(::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) + ',' + end + Next + + cQuery := Left( cQuery, len(cQuery) - 1 ) + ') VALUES (' + + For i := 1 to oRow:FCount() + if oRow:Changed(i) + cQuery += DataToSql(oRow:FieldGet(i)) + ',' + end + Next + + cQuery := Left( cQuery, len(cQuery) - 1 ) + ')' + + result := ::Execute(cQuery) + end +RETURN result + + +METHOD Update( oRow, cWhere ) CLASS TFbServer + Local result := .F., aKeys, cQuery, i, nField, xField, aTables + + aTables := oRow:GetTables() + + if ! ISNUMBER(::db) .and. len(aTables) == 1 + // Can't insert joined tables + + if ISNIL(cWhere) + 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 += ', ' + end + Next + end + + cQuery := 'UPDATE ' + aTables[1] + ' SET ' + For i := 1 to oRow:FCount() + if oRow:Changed(i) + cQuery += oRow:Fieldname(i) + ' = ' + DataToSql(oRow:FieldGet(i)) + ',' + end + Next + + if ! (cWhere == '') + cQuery := Left( cQuery, len(cQuery) - 1 ) + ' WHERE ' + cWhere + + result := ::Execute(cQuery) + end + end +RETURN result + + +CLASS TFbQuery + DATA ErrorNo + DATA nError + DATA lError + DATA Dialect + DATA lBof + DATA lEof + DATA nRecno + DATA qry + DATA aStruct + DATA numcols + DATA closed + DATA db + DATA query + DATA aKeys + DATA aTables + + METHOD New( db, 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 := .F., i, aTable := {} + + if ! ::closed + ::Destroy() + end + + ::lBof := .T. + ::lEof := .F. + ::nRecno := 0 + ::closed := .F. + ::numcols := 0 + ::aStruct := {} + ::nError := 0 + ::lError := .F. + + result := .T. + + qry := FBQuery( ::db, ::query, ::dialect ) + + if ISARRAY(qry) + ::numcols := qry[4] + + ::aStruct := StructConvert(qry[6], ::db, ::dialect) + + ::lError := .F. + ::nError := 0 + ::qry := qry + + /* Tables in query */ + For i := 1 To len(::aStruct) + if (ASCAN(aTable, ::aStruct[i,5]) == 0) + aadd( aTable, ::aStruct[i,5]) + end + Next + + ::aTables := aTable + + else + ::lError := .T. + ::nError := qry + end + +RETURN result + + +METHOD Destroy() CLASS TFbQuery + Local result := .T., n + + if (! ::lError) .and. ((n := FBFree(::qry)) < 0) + ::lError := .T. + ::nError := n + end + + ::closed := .T. + +RETURN result + + +METHOD Fetch() CLASS TFbQuery + Local result := .F., fetch_stat + + if ! ::lError .and. ! ::lEof + + if ! ::Closed + fetch_stat := FBFetch(::qry) + + ::nRecno++ + + if fetch_stat == 0 + ::lBof := .F. + result := .T. + + else + ::lEof := .T. + + end + end + end +RETURN result + + +METHOD Struct() CLASS TFbQuery + Local result := {}, i + + if ! ::lError + for i := 1 to Len(::aStruct) + aadd( result, { ::aStruct[i,1], ::aStruct[i,2], ::aStruct[i,3], ::aStruct[i,4] } ) + next + end + +RETURN result + + +METHOD FieldPos( cField ) CLASS TFbQuery + Local result := 0 + + if ! ::lError + result := AScan( ::aStruct, {|x| x[1] == trim(Upper(cField)) }) + end + +RETURN result + + +METHOD FieldName( nField ) CLASS TFbQuery + Local result + + if ! ::lError .and. nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 1] + end + +RETURN result + + +METHOD FieldType( nField ) CLASS TFbQuery + Local result + + if ! ::lError .and. nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 2] + end + +RETURN result + + +METHOD FieldLen( nField ) CLASS TFbQuery + Local result + + if ! ::lError .and. nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 3] + end +RETURN result + + +METHOD FieldDec( nField ) CLASS TFbQuery + Local result + + if ! ::lError .and. nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 4] + end +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 ! ISNIL(result) + aBlob := FBGetBlob( ::db, result) + + result := '' + For i := 1 to Len(aBlob) + result += aBlob[i] + Next + + //result := FBGetBlob( ::db, result) + else + result := '' + end + + elseif cType == "N" + if ! ISNIL(result) + result := val(result) + else + result := 0 + end + + elseif cType == "D" + if ! ISNIL(result) + result := StoD(left(result,4) + substr(result, 5, 2) + substr(result, 7, 2)) + else + result := CtoD('') + end + + elseif cType == "L" + if ! ISNIL(result) + result := (val(result) == 1) + else + result := .F. + end + end + end +RETURN result + + +METHOD Getrow() CLASS TFbQuery + Local result, aRow := {}, i + + if ! ::lError .and. ! ::closed + ASize(aRow, ::numcols) + + For i := 1 to ::numcols + aRow[i] := ::Fieldget(i) + Next + + result := TFbRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables ) + end +RETURN result + + +METHOD GetBlankRow() CLASS TFbQuery + Local result, aRow := {}, i + + if ! ::lError + ASize(aRow, ::numcols) + + For i := 1 to ::numcols + if ::aStruct[i, 2] == 'C' + aRow[i] := '' + elseif ::aStruct[i, 2] == 'N' + aRow[i] := 0 + elseif ::aStruct[i, 2] == 'L' + aRow[i] := .F. + elseif ::aStruct[i, 2] == 'D' + aRow[i] := CtoD('') + elseif ::aStruct[i, 2] == 'M' + aRow[i] := '' + end + Next + + result := TFbRow():New( aRow, ::aStruct, ::db, ::dialect, ::aTables ) + end +RETURN result + + +METHOD GetKeyField() CLASS TFbQuery + + if ISNIL(::aKeys) + ::aKeys := KeyField( ::aTables, ::db, ::dialect ) + end +RETURN ::aKeys + + +CLASS TFbRow + DATA aRow + DATA aStruct + DATA aChanged + DATA aKeys + DATA db + DATA dialect + DATA aTables + + METHOD New( row, struct, db, dialect ) + METHOD Changed(nField) + METHOD GetTables() INLINE ::aTables + METHOD FCount() INLINE Len(::aRow) + METHOD FieldGet( nField ) + METHOD FieldPut( nField, Value ) + METHOD FieldName( nField ) + METHOD FieldPos( cFieldName ) + 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 := ! ISNIL(::aChanged[nField]) + end + +RETURN result + + +METHOD FieldGet( nField ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aRow) + result := ::aRow[nField] + end + +RETURN result + + +METHOD FieldPut( nField, Value ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aRow) + ::aChanged[nField] := .T. + result := ::aRow[nField] := Value + end + +RETURN result + + +METHOD FieldName( nField ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 1] + end + +RETURN result + + +METHOD FieldPos( cField ) CLASS TFbRow + Local result := 0 + + result := AScan( ::aStruct, {|x| x[1] == trim(Upper(cField)) }) + +RETURN result + + +METHOD FieldType( nField ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 2] + end + +RETURN result + + +METHOD FieldLen( nField ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 3] + end +RETURN result + + +METHOD FieldDec( nField ) CLASS TFbRow + Local result + + if nField >= 1 .and. nField <= len(::aStruct) + result := ::aStruct[nField, 4] + end +RETURN result + + +METHOD GetKeyField() CLASS TFbRow + + if ISNIL(::aKeys) + ::aKeys := KeyField( ::aTables, ::db, ::dialect ) + end +RETURN ::aKeys + + + +Static Function KeyField( aTables, db, dialect ) + Local cTable, cQuery + Local qry, fetch_stmt + 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 ISARRAY(qry) + do while (fetch_stmt := FBFetch(qry)) == 0 + aadd(aKeys, trim(FBGetdata(qry, 1))) + end + + FBFree(qry) + end + end + +RETURN aKeys + + +Static Function DataToSql(xField) + Local cType, result + + cType := ValType(xField) + + if cType == "C" + result := '"' + strtran(xField, '"', ' ') + '"' + elseif cType == "D" + result := '"' + StrZero(month(xField),2) + '/' + StrZero(day(xField),2) + '/' + StrZero(Year(xField),4) + '"' + elseif cType == "N" + result := str(xField) + elseif cType == "L" + result := iif( xField, '1', '0' ) + end + +return result + + +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 fetch_stmt + 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 += ',' + end + 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 ISARRAY(qry) + + do while (fetch_stmt := FBFetch(qry)) == 0 + aadd( aDomains, { FBGetdata(qry, 1), FBGetdata(qry,2), FBGetdata(qry,3) } ) + end + + FBFree(qry) + + For i := 1 to Len(aStru) + cField := trim(aStru[i,1]) + nType := aStru[i,2] + nSize := aStru[i,3] + nDec := aStru[i,4] * -1 + cTable := trim(aStru[i,5]) + + nVal := AScan(aDomains, {|x| trim(x[1]) == cTable .and. trim(x[2]) == cField}) + + if nVal != 0 + cDomain := aDomains[ nVal, 3 ] + else + cDomain := '' + end + + 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 + end + 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 := "D" + 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 + end + + aadd( aNew, { cField, cType, nSize, nDec, cTable, cDomain } ) + Next + End + +return aNew + +Static Function RemoveSpaces( cQuery ) + Do While AT(" ", cQuery) != 0 + cQuery := Strtran(cQuery, " ", " ") + end +Return cQuery diff --git a/harbour/contrib/hbzlib/make_b32.bat b/harbour/contrib/hbzlib/make_b32.bat index e761428a92..6f61fc1872 100644 --- a/harbour/contrib/hbzlib/make_b32.bat +++ b/harbour/contrib/hbzlib/make_b32.bat @@ -19,7 +19,7 @@ if "%HB_CC_NAME%" == "" set HB_CC_NAME=b32 if "%HB_MAKE_PROGRAM%" == "" set HB_MAKE_PROGRAM=make.exe set HB_MAKEFILE=..\mtpl_%HB_CC_NAME%.mak -set C_USR=-Iinclude -DZLIB_DLL;WIN32;ASSERT -vi -Ve -6 -R- -H- -5 -OS -w- -X- -a8 -b -k- +set C_USR=%C_USR% -Iinclude -DZLIB_DLL;WIN32;ASSERT -vi -Ve -6 -R- -H- -5 -OS -w- -X- -a8 -b -k- rem --------------------------------------------------------------- diff --git a/harbour/contrib/hbzlib/make_vc.bat b/harbour/contrib/hbzlib/make_vc.bat index b73d6213d8..1bbd304a82 100644 --- a/harbour/contrib/hbzlib/make_vc.bat +++ b/harbour/contrib/hbzlib/make_vc.bat @@ -19,7 +19,7 @@ if "%HB_CC_NAME%" == "" set HB_CC_NAME=vc if "%HB_MAKE_PROGRAM%" == "" set HB_MAKE_PROGRAM=nmake.exe set HB_MAKEFILE=..\mtpl_%HB_CC_NAME%.mak -set C_USR=-Iinclude -DZLIB_DLL;WIN32;ASSERT +set C_USR=%C_USR% -Iinclude -DZLIB_DLL;WIN32;ASSERT rem --------------------------------------------------------------- diff --git a/harbour/contrib/mysql/test.prg b/harbour/contrib/mysql/test/test.prg similarity index 100% rename from harbour/contrib/mysql/test.prg rename to harbour/contrib/mysql/test/test.prg