fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2006-07-17 00:41 UTC+0100 Viktor Szakats (viktor.szakats syenar.hu)

Browse Source 
* harbour/common.mak
   * harbour/makefile.bc
   * harbour/makefile.vc
   * harbour/utils/Makefile
     + Added hbpptest

   * harbour/utils/hbpptest/pretest.prg
     + Output now goes to STDOUT.

   * harbour/source/compiler/harbour.c
     ! Possible memory leak fixed.

   * harbour/source/rtl/Makefile
     ! Fixed tabs (readded them).

   - harbour/source/rtl/dbdelim.prg
   + harbour/source/rdd/dbdelim.prg
   - harbour/source/rtl/dbjoin.prg
   + harbour/source/rdd/dbjoin.prg
   - harbour/source/rtl/dbsdf.prg
   + harbour/source/rdd/dbsdf.prg
   * harbour/source/rtl/Makefile
   * harbour/source/rdd/Makefile
   * harbour/common.mak
     * Moved three RDD related internal function source files
       to the RDD library. (They did depend on each other
       anyway.)

   * harbour/source/rdd/dbcmd.c
   * harbour/source/rdd/dbfuncs.prg
   * harbour/source/rdd/dblist.prg
   * harbour/source/rdd/dbsort.prg
   * harbour/source/rdd/dbstrux.prg
   * harbour/source/rdd/dbtotal.prg
   * harbour/source/rdd/dbupdat.prg
   * harbour/source/rdd/rddord.prg
   * harbour/source/rtl/dbdelim.prg
   * harbour/source/rtl/dbedit.prg
   * harbour/source/rtl/dbjoin.prg
     % Cleanups, minor optimizations.
     ! __dbApp(), __dbCopy() to return LOGICAL.
     ! Problem where error condition was not detected if BREAK didn't
       set the error object.
     ! __dbTotal() lRest handling fixed.
     ! __dbTotal() ErrorBlock overriding removed.
     ! __dbCreate() now generating default alias.
     % __dbCreate() using dbCreate() undoc param to open the tables.
     ! __dbDelim() return value.
     ! __dbSDF() return value.
     + CA-Cl*pper undocumented call added: _dtxCondSet()
     + XBase++ compatible calls implemented:
       dbJoin(), dbList(), dbSort(), dbTotal(), dbUpdate(), _dbExport()
       dbCopyStruct(), dbCopyExtStruct()
     + Added some more 10 chars call stubs:
       __dbCopySt(), __dbCopyXS(), __dbOpenSD(), __dbArrang()
     + Comments.
     + Formatting.
     ; All high-level db functions seems to be compatible now.
       DBEDIT() is left TODO for review (refix).

   * harbour/source/rtl/tbrowse.prg
     * Minor cleanup.

   * harbour/include/hbexpra.c
   * harbour/source/vm/arrayshb.c
   * harbour/source/rdd/dblist.prg
     - Removed compiler+RTL __dbList() hack which
       made it incompatible with CA-Cl*pper. The
       hack targeted an XBase++ extension, but it's
       compatible even without the hack. Tested with
       XBase++ 1.82.294.

   * harbour/source/rtl/typefile.prg
     % FUNCTION -> PROCEDURE
     + _TypeFile() XBase++ internal function added.
This commit is contained in:
Viktor Szakats
2006-07-17 00:22:56 +00:00
parent 086eb93910
commit a524f48e1f
27 changed files with 983 additions and 1474 deletions
Download Patch File Download Diff File Expand all files Collapse all files

77
harbour/ChangeLog
View File

@@ -8,6 +8,83 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
- Removed a strange extension which looked like a mistake
(besides not being CA-Cl*pper compatible).
* Comments reviewed/changed/added.
; Review done, now 100% compatible.
2006-07-17 00:41 UTC+0100 Viktor Szakats (viktor.szakats syenar.hu)
* harbour/common.mak
* harbour/makefile.bc
* harbour/makefile.vc
* harbour/utils/Makefile
+ Added hbpptest
* harbour/utils/hbpptest/pretest.prg
+ Output now goes to STDOUT.
* harbour/source/compiler/harbour.c
! Possible memory leak fixed.
* harbour/source/rtl/Makefile
! Fixed tabs (readded them).
- harbour/source/rtl/dbdelim.prg
+ harbour/source/rdd/dbdelim.prg
- harbour/source/rtl/dbjoin.prg
+ harbour/source/rdd/dbjoin.prg
* Moved three RDD related internal function source files
to the RDD library. (They did depend on each other
* harbour/source/rtl/Makefile
* harbour/source/rdd/Makefile
* harbour/common.mak
* Moved three RDD related internal function source files
to the RDD library. (They did depend on each other
anyway.)
* harbour/source/rdd/dbcmd.c
* harbour/source/rdd/dbfuncs.prg
* harbour/source/rdd/dblist.prg
* harbour/source/rdd/dbsort.prg
* harbour/source/rdd/dbstrux.prg
* harbour/source/rdd/dbtotal.prg
* harbour/source/rdd/dbupdat.prg
* harbour/source/rdd/rddord.prg
! Problem where error condition was not detected if BREAK didn't
* harbour/source/rtl/dbedit.prg
* harbour/source/rtl/dbjoin.prg
% Cleanups, minor optimizations.
! __dbApp(), __dbCopy() to return LOGICAL.
! Problem where error condition was not detected if BREAK didn't
set the error object.
! __dbTotal() lRest handling fixed.
! __dbTotal() ErrorBlock overriding removed.
! __dbCreate() now generating default alias.
% __dbCreate() using dbCreate() undoc param to open the tables.
! __dbDelim() return value.
! __dbSDF() return value.
+ CA-Cl*pper undocumented call added: _dtxCondSet()
+ XBase++ compatible calls implemented:
dbJoin(), dbList(), dbSort(), dbTotal(), dbUpdate(), _dbExport()
dbCopyStruct(), dbCopyExtStruct()
+ Added some more 10 chars call stubs:
__dbCopySt(), __dbCopyXS(), __dbOpenSD(), __dbArrang()
+ Comments.
+ Formatting.
; All high-level db functions seems to be compatible now.
DBEDIT() is left TODO for review (refix).
* harbour/source/rtl/tbrowse.prg
- Removed compiler+RTL __dbList() hack which
made it incompatible with CA-Cl*pper. The
hack targeted an XBase++ extension, but it's
compatible even without the hack. Tested with
* harbour/source/rdd/dblist.prg
- Removed compiler+RTL __dbList() hack which
made it incompatible with CA-Cl*pper. The
hack targeted an XBase++ extension, but it's
compatible even without the hack. Tested with
XBase++ 1.82.294.
2006-07-16 23:26 UTC+0100 Enrico Maria Giordano <e.m.giordano@emagsoftware.it>
* harbour/source/rtl/typefile.prg
% FUNCTION -> PROCEDURE

16
harbour/common.mak
View File

@@ -55,10 +55,10 @@ GTGUI_DIR = source\rtl\gtgui
HARBOUR_DIR = source\compiler
HBPP_DIR = utils\hbpp
HBPPTEST_DIR = utils\hbpptest
HBRUN_DIR = utils\hbrun
HBTEST_DIR = utils\hbtest
HBDOC_DIR = utils\hbdoc
HBPP_DIR = utils\hbpp
HBMAKE_DIR = utils\hbmake
HBVER_DIR = utils\hbver
@@ -95,6 +95,7 @@ $(GTWVT_DIR);\
$(GTGUI_DIR);\
$(HARBOUR_DIR);\
$(HBPP_DIR);\
$(HBPPTEST_DIR);\
$(HBRUN_DIR);\
$(HBTEST_DIR);\
$(HBDOC_DIR);\
@@ -138,6 +139,7 @@ GTGUI_LIB = $(LIB_DIR)\gtgui.lib
HARBOUR_EXE = $(BIN_DIR)\harbour.exe
HBPP_EXE = $(BIN_DIR)\hbpp.exe
HBPPTEST_EXE = $(BIN_DIR)\hbpptest.exe
HBRUN_EXE = $(BIN_DIR)\hbrun.exe
HBTEST_EXE = $(BIN_DIR)\hbtest.exe
HBDOC_EXE = $(BIN_DIR)\hbdoc.exe
@@ -411,9 +413,6 @@ RTL_LIB_OBJS = \
$(OBJ_DIR)\color53.obj \
$(OBJ_DIR)\date.obj \
$(OBJ_DIR)\dbedit.obj \
$(OBJ_DIR)\dbdelim.obj \
$(OBJ_DIR)\dbsdf.obj \
$(OBJ_DIR)\dbjoin.obj \
$(OBJ_DIR)\devoutp.obj \
$(OBJ_DIR)\dircmd.obj \
$(OBJ_DIR)\dummy.obj \
@@ -595,6 +594,9 @@ RDD_LIB_OBJS = \
$(OBJ_DIR)\delim1.obj \
$(OBJ_DIR)\sdf1.obj \
\
$(OBJ_DIR)\dbdelim.obj \
$(OBJ_DIR)\dbsdf.obj \
$(OBJ_DIR)\dbjoin.obj \
$(OBJ_DIR)\dbtotal.obj \
$(OBJ_DIR)\dbfuncs.obj \
$(OBJ_DIR)\dblist.obj \
@@ -725,6 +727,11 @@ HBPP_EXE_OBJS = \
#**********************************************************
HBPPTEST_EXE_OBJS = \
$(OBJ_DIR)\pretest.obj \
#**********************************************************
HBRUN_EXE_OBJS = \
$(OBJ_DIR)\hbrun.obj \
$(OBJ_DIR)\external.obj \
@@ -862,6 +869,7 @@ HB_BUILD_TARGETS = \
\
$(HBRUN_EXE) \
$(HBTEST_EXE) \
$(HBPPTEST_EXE) \
$(HBDOC_EXE) \
$(HBMAKE_EXE) \
$(HBVER_EXE) \

88
harbour/include/hbexpra.c
View File

@@ -402,94 +402,6 @@ HB_EXPR_PTR hb_compExprNewFunCall( HB_EXPR_PTR pName, HB_EXPR_PTR pParms )
HB_EXPR_PCODE1( hb_compExprDelete, pName );
return pEval;
}
else if( HB_COMP_ISSUPPORTED( HB_COMPFLAG_XBASE ) &&
(( strcmp( "__DBLIST", pName->value.asSymbol ) == 0 ) && iCount >= 10) )
{
HB_EXPR_PTR pArray = pParms->value.asList.pExprList->pNext;
if( pArray->ExprType == HB_ET_ARRAY )
{
HB_EXPR_PTR pElem = pArray->value.asList.pExprList;
HB_EXPR_PTR pPrev = NULL, pNext;
while( pElem )
{
/* The {|| &cMacro } block is now &( "{||" + cMacro + "}" ) due to early macro expansion in compiler. */
if( pElem->ExprType == HB_ET_MACRO )
{
HB_EXPR_PTR pMacro = pElem->value.asMacro.pExprList;
if( pMacro &&
pMacro->ExprType == HB_EO_PLUS &&
pMacro->value.asOperator.pLeft->ExprType == HB_EO_PLUS &&
pMacro->value.asOperator.pLeft->value.asOperator.pRight->ExprType == HB_ET_VARIABLE
)
{
/* Saving the next array element so the list can be relinked after we substitute the macro block. */
pNext = pElem->pNext;
/* Instead we only want the macro variable, {|| &cMacro } -> &( "{||" + cMacro + "}" ) -> cMacro */
hb_compExprClear( pElem );
pElem = pMacro->value.asOperator.pLeft->value.asOperator.pRight;
if( pPrev )
{
/* Previous element should point to the new element. */
pPrev->pNext = pElem;
}
else
{
/* Top of array should point to the new first element. */
pArray->value.asList.pExprList = pElem;
}
pElem->pNext = pNext;
}
}
/* Search for {|| &(cMacro) }. */
else if( pElem->ExprType == HB_ET_CODEBLOCK )
{
HB_EXPR_PTR pBlock = pElem->value.asCodeblock.pExprList;
/* Search for macros {|| &cMacro }. */
if( pBlock->ExprType == HB_ET_MACRO )
{
/* Saving the next array element so the list can be relinked after we substitute the macro block. */
pNext = pElem->pNext;
/* Instead we only want the core expression. */
hb_compExprClear( pElem );
if( pBlock->value.asMacro.pExprList ) /* &( exp ) -> exp */
{
pElem = pBlock->value.asMacro.pExprList;
}
else if( pBlock->value.asMacro.cMacroOp ) /* simple macro in Flex build {|| &cMacro}, because harbour.y does not support early macros yet*/
{
pElem = hb_compExprNewVar( pBlock->value.asMacro.szMacro );
}
else /* {|| &cMacro.suffix } -> cMacro + "suffix" */
{
char *cStr = pBlock->value.asMacro.szMacro;
pElem = hb_compExprNewString( cStr, strlen(cStr) );
}
if( pPrev )
{
/* Previous element should point to the new element. */
pPrev->pNext = pElem;
}
else
{
/* Top of array should point to the new first element. */
pArray->value.asList.pExprList = pElem;
}
pElem->pNext = pNext;
}
}
pPrev = pElem;
pElem = pElem->pNext;
}
}
}
#ifndef SIMPLEX
else if( ( strcmp( "_GET_", pName->value.asSymbol ) == 0 ) && iCount )

15
harbour/makefile.bc
View File

@@ -430,6 +430,21 @@ $(PP_LIB)
!
#**********************************************************
#
# HBPPTEST build rule
#
$(HBPPTEST_EXE) :: BasicLibs BasicExes StdLibs
$(HBPPTEST_EXE) :: $(HBPPTEST_EXE_OBJS)
$(HIDE)IF EXIST "$(HBPPTEST_EXE)" $(DEL) "$(HBPPTEST_EXE)" > NUL
$(HIDE)$(CC) @&&!
$(CFLAGS)
-e$(HBPPTEST_EXE)
$(**: = ^
)
$(STANDARD_STATIC_HBLIBS)
$(PP_LIB)
!
#**********************************************************
#
# HBRUN build rule
#
$(HBRUN_EXE) :: BasicLibs BasicExes StdLibs

28
harbour/makefile.vc
View File

@@ -211,6 +211,9 @@ DLL_OBJS = $(TMP_DLL_OBJS:obj\vc=obj\dll\vc)
{$(HBPP_DIR)}.c{$(OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $<
#*******************************************************
{$(HBPPTEST_DIR)}.c{$(OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $<
#*******************************************************
{$(HBRUN_DIR)}.c{$(OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $<
#*******************************************************
@@ -330,6 +333,10 @@ DLL_OBJS = $(TMP_DLL_OBJS:obj\vc=obj\dll\vc)
$(HIDE)$(HARBOUR_EXE) $(HARBOURFLAGS) $< -o$(OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
#*******************************************************
{$(HBPPTEST_DIR)}.prg{$(OBJ_DIR)}.obj:
$(HIDE)$(HARBOUR_EXE) $(HARBOURFLAGS) $< -o$(OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
#*******************************************************
{$(HBRUN_DIR)}.prg{$(OBJ_DIR)}.obj:
$(HIDE)$(HARBOUR_EXE) $(HARBOURFLAGS) $< -o$(OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGS) -Fo$(OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
@@ -429,6 +436,9 @@ DLL_OBJS = $(TMP_DLL_OBJS:obj\vc=obj\dll\vc)
{$(HBPP_DIR)}.c{$(DLL_OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $<
#*******************************************************
{$(HBPPTEST_DIR)}.c{$(DLL_OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $<
#*******************************************************
{$(HBRUN_DIR)}.c{$(DLL_OBJ_DIR)}.obj::
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $<
#*******************************************************
@@ -548,6 +558,10 @@ DLL_OBJS = $(TMP_DLL_OBJS:obj\vc=obj\dll\vc)
$(HIDE)$(HARBOUR_EXE) -D__EXPORT__ $(HARBOURFLAGS) $< -o$(DLL_OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
#*******************************************************
{$(HBPPTEST_DIR)}.prg{$(DLL_OBJ_DIR)}.obj:
$(HIDE)$(HARBOUR_EXE) -D__EXPORT__ $(HARBOURFLAGS) $< -o$(DLL_OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
#*******************************************************
{$(HBRUN_DIR)}.prg{$(DLL_OBJ_DIR)}.obj:
$(HIDE)$(HARBOUR_EXE) -D__EXPORT__ $(HARBOURFLAGS) $< -o$(DLL_OBJ_DIR)\\
$(HIDE)$(CC) $(CLIBFLAGSDLL) -Fo$(DLL_OBJ_DIR)\ $(OBJ_DIR)\$(*B).c
@@ -731,6 +745,20 @@ $(PP_LIB)
<<
#**********************************************************
#
# HBPPTEST build rule
#
$(HBPPTEST_EXE) : $(HBPPTEST_EXE_OBJS)
$(HIDE)IF EXIST "$(HBPPTEST_EXE)" $(DEL) "$(HBPPTEST_EXE)" > NUL
$(HIDE)$(LINKER) @<<
$(LDFLAGS)
/OUT:$(HBPPTEST_EXE)
$(**: = ^
)
$(STANDARD_STATIC_HBLIBS)
$(PP_LIB)
<<
#**********************************************************
#
# HBRUN build rule
#
$(HBRUN_EXE) : $(HBRUN_EXE_OBJS)

3
harbour/source/compiler/harbour.c
View File

@@ -414,10 +414,11 @@ static int hb_compProcessRSPFile( char * szRspName, int argc, char * argv[] )
hb_comp_bAutoOpen = bAutoOpen;
hb_fsFNameMerge( szFile, pFileName );
hb_xfree( pFileName );
hb_compCompile( szFile, argc, argv, FALSE );
}
hb_xfree( pFileName );
return iStatus;
}

3
harbour/source/rdd/Makefile
View File

@@ -14,9 +14,12 @@ C_SOURCES=\
hbdbsort.c \
PRG_SOURCES=\
dbdelim.prg \
dbfuncs.prg \
dbjoin.prg \
dbtotal.prg \
dblist.prg \
dbsdf.prg \
dbsort.prg \
dbstrux.prg \
dbupdat.prg \

66
harbour/source/rdd/dbcmd.c
View File

@@ -4614,62 +4614,72 @@ HB_FUNC( __DBTRANS )
HB_FUNC( __DBAPP )
{
BOOL bRetVal;
if( ISCHAR( 1 ) )
{
AREAP pArea = ( AREAP ) hb_rddGetCurrentWorkAreaPointer();
if( pArea )
{
hb_rddTransRecords( pArea,
hb_parc( 1 ), /* file name */
hb_parc( 8 ), /* RDD */
hb_parnl( 9 ), /* connection */
hb_param( 2, HB_IT_ARRAY ), /* Fields */
FALSE, /* Export? */
hb_param( 3, HB_IT_BLOCK ), /* cobFor */
NULL, /* lpStrFor */
hb_param( 4, HB_IT_BLOCK ), /* cobWhile */
NULL, /* lpStrWhile */
hb_param( 5, HB_IT_NUMERIC ), /* Next */
bRetVal = ( SUCCESS == hb_rddTransRecords( pArea,
hb_parc( 1 ), /* file name */
hb_parc( 8 ), /* RDD */
hb_parnl( 9 ), /* connection */
hb_param( 2, HB_IT_ARRAY ), /* Fields */
FALSE, /* Export? */
hb_param( 3, HB_IT_BLOCK ), /* cobFor */
NULL, /* lpStrFor */
hb_param( 4, HB_IT_BLOCK ), /* cobWhile */
NULL, /* lpStrWhile */
hb_param( 5, HB_IT_NUMERIC ), /* Next */
ISNIL( 6 ) ? NULL : hb_param( 6, HB_IT_ANY ), /* RecID */
hb_param( 7, HB_IT_LOGICAL ), /* Rest */
hb_parc( 10 ), /* Codepage */
hb_param( 11, HB_IT_STRING ) );/* Delimiter */
hb_param( 7, HB_IT_LOGICAL ), /* Rest */
hb_parc( 10 ), /* Codepage */
hb_param( 11, HB_IT_STRING ) ) ); /* Delimiter */
}
else
{
hb_errRT_DBCMD( EG_NOTABLE, EDBCMD_NOTABLE, NULL, "APPEND FROM" );
bRetVal = FALSE;
}
}
hb_retl( bRetVal );
}
HB_FUNC( __DBCOPY )
{
BOOL bRetVal;
if( ISCHAR( 1 ) )
{
AREAP pArea = ( AREAP ) hb_rddGetCurrentWorkAreaPointer();
if( pArea )
{
hb_rddTransRecords( pArea,
hb_parc( 1 ), /* file name */
hb_parc( 8 ), /* RDD */
hb_parnl( 9 ), /* connection */
hb_param( 2, HB_IT_ARRAY ), /* Fields */
TRUE, /* Export? */
hb_param( 3, HB_IT_BLOCK ), /* cobFor */
NULL, /* lpStrFor */
hb_param( 4, HB_IT_BLOCK ), /* cobWhile */
NULL, /* lpStrWhile */
hb_param( 5, HB_IT_NUMERIC ), /* Next */
bRetVal = ( SUCCESS == hb_rddTransRecords( pArea,
hb_parc( 1 ), /* file name */
hb_parc( 8 ), /* RDD */
hb_parnl( 9 ), /* connection */
hb_param( 2, HB_IT_ARRAY ), /* Fields */
TRUE, /* Export? */
hb_param( 3, HB_IT_BLOCK ), /* cobFor */
NULL, /* lpStrFor */
hb_param( 4, HB_IT_BLOCK ), /* cobWhile */
NULL, /* lpStrWhile */
hb_param( 5, HB_IT_NUMERIC ), /* Next */
ISNIL( 6 ) ? NULL : hb_param( 6, HB_IT_ANY ), /* RecID */
hb_param( 7, HB_IT_LOGICAL ), /* Rest */
hb_parc( 10 ), /* Codepage */
hb_param( 11, HB_IT_STRING ) );/* Delimiter */
hb_param( 7, HB_IT_LOGICAL ), /* Rest */
hb_parc( 10 ), /* Codepage */
hb_param( 11, HB_IT_STRING ) ) ); /* Delimiter */
}
else
{
hb_errRT_DBCMD( EG_NOTABLE, EDBCMD_NOTABLE, NULL, "COPY TO" );
bRetVal = FALSE;
}
}
hb_retl( bRetVal );
}
HB_EXPORT ERRCODE hb_rddGetTempAlias( char * szAliasTmp )

120
harbour/source/rdd/dbdelim.prg Normal file
View File

@@ -0,0 +1,120 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Copies the contents of a database to a delimited text file.
* Appends the contents of a delimited text file to a database.
*
* Copyright 2001-2003 David G. Holm <dholm@jsd-llc.com>
* www - http://www.harbour-project.org
* APPEND FROM code submitted by Marco Braida <marcobra@elart.it>
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* function __dbDelim() replaced by the new one which uses
* DELIM RDD I've just created
*
* 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.
*
*/
#include "hbsetup.ch"
REQUEST DELIM
FUNCTION __dbDelim( lExport, cFile, cDelimArg, aFields, bFor, bWhile, nNext, nRecord, lRest )
#ifdef HB_C52_STRICT
LOCAL nSrcArea
LOCAL nDstArea
LOCAL aStruct
LOCAL cRDD := "DELIM"
IF lExport
nSrcArea := Select()
ELSE
nDstArea := Select()
ENDIF
IF Empty( aStruct := __dbStructFilter( dbStruct(), aFields ) )
RETURN .F.
ENDIF
IF lExport
dbCreate( cFile, aStruct, cRDD, .T., "", cDelimArg )
nDstArea := Select()
IF nDstArea == nSrcArea
nDstArea := NIL
ENDIF
dbSelectArea( nSrcArea )
ELSE
IF !__dbOpenSDF( cFile, aStruct, cRDD, .T., "", cDelimArg )
RETURN .F.
ENDIF
nSrcArea := Select()
ENDIF
IF nDstArea != NIL
__dbTrans( nDstArea, aStruct, bFor, bWhile, nNext, nRecord, lRest )
ENDIF
IF lExport
IF nDstArea != NIL
dbSelectArea( nDstArea )
dbCloseArea()
ENDIF
dbSelectArea( nSrcArea )
ELSE
dbSelectArea( nSrcArea )
dbCloseArea()
dbSelectArea( nDstArea )
ENDIF
RETURN .T.
#else
RETURN iif( lExport,;
__dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "DELIM", , , cDelimArg ) ,;
__dbApp( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "DELIM", , , cDelimArg ) )
#endif

110
harbour/source/rdd/dbfuncs.prg
View File

@@ -50,41 +50,93 @@
*
*/
FUNCTION DBCLEARFIL()
Return DBCLEARFILTER()
#include "hbsetup.ch"
FUNCTION DBSETDRIVE(cDriver)
Return DBSETDRIVER(cDriver)
/* short (10 chars long) version of some functions for compatibility */
FUNCTION DBSETRELAT(xArea,bRelation,cRelation,lScoped)
Return DBSETRELATION(xArea,bRelation,cRelation,lScoped)
FUNCTION dbClearFil()
RETURN dbClearFilter()
FUNCTION DBRLOCKLIS()
Return DBRLOCKLIST()
FUNCTION dbSetDrive( cRDD )
RETURN dbSetDriver( cRDD )
FUNCTION DBCLOSEARE()
Return DBCLOSEAREA()
FUNCTION RDDSETDEFA(xDriver)
Return RDDSETDEFAULT(xDriver)
FUNCTION dbSetRelat( xArea, bRelation, cRelation, lScoped )
RETURN dbSetRelation( xArea, bRelation, cRelation, lScoped )
FUNCTION DBSELECTAR(xArea)
Return DBSELECTAREA(xArea)
FUNCTION dbRLockLis()
RETURN dbRLockList()
FUNCTION DBUNLOCKAL()
Return DBUNLOCKALL()
FUNCTION dbCloseAre()
RETURN dbCloseArea()
FUNCTION DBCLEARREL()
Return DBCLEARRELATION()
FUNCTION DBSETFILTE(bFilter,cFilter)
Return DBSETFILTER(bFilter,cFilter)
FUNCTION dbSelectAr( xArea )
RETURN dbSelectArea( xArea )
FUNCTION DBFIELDINF(nType,nArea,xInfo)
Return DBFIELDINFO(nType,nArea,xInfo)
FUNCTION DBORDERINF(nInfo,cIndex,xOrder,xSet)
Return DBORDERINFO(nInfo,cIndex,xOrder,xSet)
FUNCTION dbUnLockAl()
RETURN dbUnLockAll()
FUNCTION DBRECORDIN(nInfo,nRecord,xSet)
Return DBRECORDINFO(nInfo,nRecord,xSet)
FUNCTION dbClearRel()
RETURN dbClearRelation()
FUNCTION dbSetFilte( bFilter, cFilter )
RETURN dbSetFilter( bFilter, cFilter )
FUNCTION dbFieldInf( nType, nArea, xInfo )
RETURN dbFieldInfo( nType, nArea, xInfo )
FUNCTION dbOrderInf( nInfo, cIndex, xOrder, xSet )
RETURN dbOrderInfo( nInfo, cIndex, xOrder, xSet )
FUNCTION dbRecordIn( nInfo, nRecord, xSet )
RETURN dbRecordInfo( nInfo, nRecord, xSet )
FUNCTION rddSetDefa( cRDD )
RETURN rddSetDefault( cRDD )
FUNCTION __dbCopySt( cFileName, aFieldList )
RETURN __dbCopyStruct( cFileName, aFieldList )
FUNCTION __dbCopyXS( cFileName )
RETURN __dbCopyXStruct( cFileName )
/* ; NOTE: The created table will be kept open if lOpenMode parameter
is of logical type. If .T. it will be opened in a new workarea,
if .F. it will be opened in the current one. */
/* ; NOTE: Has an identical parameter list with dbCreate() */
FUNCTION __dbOpenSD( cFile, aStruct, cRDD, lOpenMode, cAlias, cDelimArg, cCodePage, nConnection )
RETURN __dbOpenSDF( cFile, aStruct, cRDD, lOpenMode, cAlias, cDelimArg, cCodePage, nConnection )
FUNCTION __dbArrang( nToArea, aStruct, bFor, bWhile, nNext, nRecord, lRest, aFields )
RETURN __dbArrange( nToArea, aStruct, bFor, bWhile, nNext, nRecord, lRest, aFields )
FUNCTION ordListCle()
RETURN ordListClear()
FUNCTION ordListReb()
RETURN ordListRebuild()
FUNCTION ordSetFocu( xOrder, cFile )
RETURN ordSetFocus( xOrder, cFile )
FUNCTION ordSetRela( xArea, bRelation, cRelation )
RETURN ordSetRelation( xArea, bRelation, cRelation )
#ifdef HB_COMPAT_XPP
FUNCTION _dbExport( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, cXPP_Driver, cDelimiter )
DO CASE
CASE cXPP_Driver == "SDFDBE"
RETURN __dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "SDF" )
/* Alternate CA-Cl*pper compatible call:
RETURN __dbSDF( .T., cFile, aFields, bFor, bWhile, nNext, nRecord, lRest ) */
CASE cXPP_Driver == "DELDBE"
RETURN __dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "DELIM", , , cDelimiter )
/* Alternate CA-Cl*pper compatible call:
RETURN __dbDelim( .T., cFile, cDelimiter, aFields, bFor, bWhile, nNext, nRecord, lRest ) */
ENDCASE
RETURN __dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, cXPP_Driver )
#endif

180
harbour/source/rdd/dbjoin.prg Normal file
View File

@@ -0,0 +1,180 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* __DBJOIN() function
*
* Copyright 2005 Pavel Tsarenko <tpe2@mail.ru>
* www - http://www.harbour-project.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.
*
*/
#include "hbsetup.ch"
#include "dbstruct.ch"
/* NOTE: Compared to CA-Cl*pper, Harbour has three extra parameters
(cRDD, nConnection, cCodePage). */
FUNCTION __dbJoin( cAlias, cFile, aFields, bFor, cRDD, nConnection, cCodePage )
LOCAL nMaster := Select()
LOCAL nDetail := Select( cAlias )
LOCAL nResult
LOCAL aStruct
LOCAL aJoinList
LOCAL oError
LOCAL lError := .F.
dbSelectArea( nMaster )
IF Empty( aStruct := __FieldTwo( cAlias, aFields ) )
RETURN .F.
ENDIF
BEGIN SEQUENCE
dbCreate( cFile, aStruct, cRDD, .T., "", NIL, cCodePage, nConnection )
nResult := Select()
aJoinList := __JoinList( nMaster, nDetail, nResult, aStruct )
dbSelectArea( nMaster )
dbGoTop()
DO WHILE !Eof()
dbSelectArea( nDetail )
dbGoTop()
DO WHILE !Eof()
dbSelectArea( nMaster )
IF Eval( bFor )
__doJoinList( aJoinList )
ENDIF
dbSelectArea( nDetail )
dbSkip()
ENDDO
dbSelectArea( nMaster )
dbSkip()
ENDDO
RECOVER USING oError
lError := .T.
END SEQUENCE
IF nResult != NIL
dbSelectArea( nResult )
dbCloseArea()
ENDIF
dbSelectArea( nMaster )
IF lError
Break( oError )
ENDIF
RETURN .T.
STATIC FUNCTION __FieldTwo( cAlias, aFields )
LOCAL aFldTemp
LOCAL bFind
LOCAL aStruct
LOCAL cField
IF Empty( aFields )
RETURN dbStruct()
ENDIF
aFldTemp := {}
AEval( aFields, {| cFld | AAdd( aFldTemp, Trim( Upper( cFld ) ) ) } )
aFields := aFldTemp
aStruct := {}
bFind := {| cFld | cFld == cField }
AEval( dbStruct(), {| aFld | cField := aFld[ DBS_NAME ],;
iif( AScan( aFields, bFind ) == 0, NIL, AAdd( aStruct, aFld ) ) } )
Select( cAlias )
bFind := {| cFld | "->" $ cFld .AND. SubStr( cFld, At( "->", cFld ) + 2 ) == cField }
AEval( dbStruct(), {| aFld | cField := aFld[ DBS_NAME ],;
iif( AScan( aFields, bFind ) == 0, NIL, AAdd( aStruct, aFld ) ) } )
RETURN aStruct
STATIC FUNCTION __JoinList( nMaster, nDetail, nResult, aStruct )
LOCAL aList := {}
LOCAL nPos
LOCAL i
FOR i := 1 TO Len( aStruct )
IF ( nPos := ( nMaster )->( FieldPos( aStruct[ i ][ DBS_NAME ] ) ) ) != 0
AAdd( aList, { nResult, nMaster, nPos, i } )
ELSEIF ( nPos := ( nDetail )->( FieldPos( aStruct[ i ][ DBS_NAME ] ) ) ) != 0
AAdd( aList, { nResult, nDetail, nPos, i } )
ENDIF
NEXT
RETURN aList
STATIC PROCEDURE __doJoinList( aList )
LOCAL aJoin
IF Len( aList ) > 0
( aList[ 1 ][ 1 ] )->( dbAppend() )
FOR EACH aJoin IN aList
( aJoin[ 1 ] )->( FieldPut( aJoin[ 4 ], ( aJoin[ 2 ] )->( FieldGet( aJoin[ 3 ] ) ) ) )
NEXT
ENDIF
RETURN
#ifdef HB_COMPAT_XPP
FUNCTION dbJoin( cAlias, cFile, aFields, bFor )
RETURN __dbJoin( cAlias, cFile, aFields, bFor )
#endif

62
harbour/source/rdd/dblist.prg
View File

@@ -48,20 +48,13 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
* The following parts are Copyright of the individual authors.
* www - http://www.harbour-project.org
*
* Copyright 2000 RonPinkas <Ron@Profit-Master.com>
* HB_aExpressions()
*
*/
/* NOTE: lAll is basically a dummy parameter, nothing really depends on it.
[vszakats] */
#include "hbsetup.ch"
#include "set.ch"
/* NOTE: lAll is a dummy parameter, nothing seems to depend on it. [vszakats] */
FUNCTION __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToPrint, cToFileName )
PROCEDURE __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToPrint, cToFileName )
LOCAL lOldPrinter
LOCAL lOldExtra
@@ -71,44 +64,17 @@ FUNCTION __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToP
LOCAL cExt
LOCAL oError
LOCAL lError := .F.
LOCAL bOutBlock
LOCAL nLen := Len( abEval ), nIndex, asMacros, nMacros, nMacroIndex
// Scan for strings instead of blocks - These are macros that need to be compiled into blocks.
FOR nIndex := 1 TO nLen
IF ValType( abEval[ nIndex ] ) == 'C'
//? abEval[ nIndex ]
// Macro may be a comma seperated list.
asMacros := HB_aExpressions( abEval[ nIndex ] )
nMacros := Len( asMacros )
// Array has to be sized to allow dor the extra blocks
nLen += ( nMacros - 1 )
aSize( abEval, nLen )
// We will use the place holder of the string for the first new block.
abEval[ nIndex ] := &( "{||" + asMacros[ 1 ] + "}" )
// We will now push all subsequent blocks 1 at a time and insert the new block inplace.
FOR nMacroIndex := 2 TO nMacros
aIns( abEval, nIndex + nMacroIndex - 1 )
abEval[ nIndex + nMacroIndex - 1 ] := &( "{||" + asMacros[ nMacroIndex ] + "}" )
NEXT
// The loop counter should skip the new elements.
nIndex += ( nMacros - 1 )
ENDIF
NEXT
/* Choose the output style */
IF lOff
bOutBlock := {|| QOut( iif( Deleted(), "*", " " ) ),;
aEval( abEval, {| bEval | QQOut( Eval( bEval ), "" ) } ) }
AEval( abEval, {| bEval | QQOut( Eval( bEval ), "" ) } ) }
ELSE
bOutBlock := {|| QOut( Str( RecNo(), 7 ), iif( Deleted(), "*", " " ) ),;
aEval( abEval, {| bEval | QQOut( Eval( bEval ), "" ) } ) }
AEval( abEval, {| bEval | QQOut( Eval( bEval ), "" ) } ) }
ENDIF
/* Save SETs */
@@ -122,7 +88,7 @@ FUNCTION __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToP
cExt := ".txt"
ENDIF
lOldExtra := Set( _SET_EXTRA, .T. )
cOldExtraFile := Set( _SET_EXTRAFILE, hb_FNameMerge( @cPath, @cName, @cExt ) )
cOldExtraFile := Set( _SET_EXTRAFILE, hb_FNameMerge( cPath, cName, cExt ) )
ENDIF
/* Do the job */
@@ -142,9 +108,10 @@ FUNCTION __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToP
ENDIF
RECOVER USING oError
lError := .T.
END SEQUENCE
/* Restor SETs */
/* Restore SETs */
IF !Empty( lToPrint )
Set( _SET_PRINTER, lOldPrinter )
@@ -156,8 +123,15 @@ FUNCTION __dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToP
/* On error signal the error for the higher level error handler or quit */
IF oError != NIL
IF lError
Break( oError )
ENDIF
RETURN NIL
RETURN
#ifdef HB_COMPAT_XPP
FUNCTION dbList( lOff, abEval, lAll, bFor, bWhile, nNext, nRecord, lRest, lToPrint, cToFileName )
RETURN __dbList( abEval, lOff, lAll, bFor, bWhile, nNext, nRecord, lRest, lToPrint, cToFileName )
#endif

63
harbour/source/rdd/dbsdf.prg Normal file
View File

@@ -0,0 +1,63 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Copies the contents of a database to an SDF text file.
* Appends the contents of an SDF text file to a database.
*
* Copyright 2001-2002 David G. Holm <dholm@jsd-llc.com>
* www - http://www.harbour-project.org
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* function __dbSDF() replaced by the new one which uses
* SDF RDD I've just created
*
* 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.
*
*/
REQUEST SDF
FUNCTION __dbSDF( lExport, cFile, aFields, bFor, bWhile, nNext, nRecord, lRest )
RETURN iif( lExport,;
__dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "SDF" ) ,;
__dbApp( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "SDF" ) )

31
harbour/source/rdd/dbsort.prg
View File

@@ -50,14 +50,21 @@
*
*/
#include "hbsetup.ch"
/* NOTE: Compared to CA-Cl*pper, Harbour has three extra parameters
(cRDD, nConnection, cCodePage). */
FUNCTION __dbSort( cToFileName, aFields, bFor, bWhile, nNext, nRecord, lRest,;
cRddName, nConnection, cdpId )
LOCAL nArea
cRDD, nConnection, cCodePage )
LOCAL nOldArea
LOCAL nToArea
LOCAL aStruct
LOCAL oError
nArea := Select()
LOCAL oError
LOCAL lError := .F.
nOldArea := Select()
aStruct := dbStruct()
IF Empty( aStruct )
@@ -66,12 +73,13 @@ FUNCTION __dbSort( cToFileName, aFields, bFor, bWhile, nNext, nRecord, lRest,;
BEGIN SEQUENCE
dbCreate( cToFileName, aStruct, cRddName, .T., "", , cdpID, nConnection )
dbCreate( cToFileName, aStruct, cRDD, .T., "", NIL, cCodePage, nConnection )
nToArea := Select()
dbSelectArea( nArea )
dbSelectArea( nOldArea )
__dbArrange( nToArea, aStruct, bFor, bWhile, nNext, nRecord, lRest, aFields )
RECOVER USING oError
lError := .T.
END SEQUENCE
IF nToArea != NIL
@@ -79,10 +87,17 @@ FUNCTION __dbSort( cToFileName, aFields, bFor, bWhile, nNext, nRecord, lRest,;
dbCloseArea()
ENDIF
dbSelectArea( nArea )
dbSelectArea( nOldArea )
IF oError != NIL
IF lError
Break( oError )
ENDIF
RETURN .T.
#ifdef HB_COMPAT_XPP
FUNCTION dbSort( cToFileName, aFields, bFor, bWhile, nNext, nRecord, lRest )
RETURN __dbSort( cToFileName, aFields, bFor, bWhile, nNext, nRecord, lRest )
#endif

68
harbour/source/rdd/dbstrux.prg
View File

@@ -60,9 +60,11 @@ FUNCTION __dbCopyStruct( cFileName, aFieldList )
FUNCTION __dbCopyXStruct( cFileName )
LOCAL nOldArea
LOCAL oError
LOCAL aStruct
LOCAL oError
LOCAL lError := .F.
IF Empty( aStruct := dbStruct() )
RETURN .F.
ENDIF
@@ -72,21 +74,20 @@ FUNCTION __dbCopyXStruct( cFileName )
BEGIN SEQUENCE
dbSelectArea( 0 )
__dbCreate( cFileName, NIL, NIL, .F., "" )
__dbCreate( cFileName, NIL, NIL, .F., NIL )
AEval( aStruct, {| aField | iif( aField[ DBS_TYPE ] == "C" .AND. aField[ DBS_LEN ] > 255, ;
( aField[ DBS_DEC ] := Int( aField[ DBS_LEN ] / 256 ), aField[ DBS_LEN ] := aField[ DBS_LEN ] % 256 ), NIL ) } )
AEval( aStruct, {| aField | dbAppend(),;
AEval( aStruct, {| aField | iif( aField[ DBS_TYPE ] == "C" .AND. aField[ DBS_LEN ] > 255,;
( aField[ DBS_DEC ] := Int( aField[ DBS_LEN ] / 256 ), aField[ DBS_LEN ] := aField[ DBS_LEN ] % 256 ), NIL ),;
dbAppend(),;
FIELD->FIELD_NAME := aField[ DBS_NAME ],;
FIELD->FIELD_TYPE := aField[ DBS_TYPE ],;
FIELD->FIELD_LEN := aField[ DBS_LEN ], ;
FIELD->FIELD_LEN := aField[ DBS_LEN ],;
FIELD->FIELD_DEC := aField[ DBS_DEC ] } )
/* NOTE: CA-Cl*pper has a bug, where only a plain RECOVER statement is
used here (without the USING keyword), so oError will always be
NIL. */
used here (without the USING keyword), so oError will always be NIL. */
RECOVER USING oError
lError := .T.
END SEQUENCE
IF Select() != nOldArea
@@ -94,20 +95,28 @@ FUNCTION __dbCopyXStruct( cFileName )
dbSelectArea( nOldArea )
ENDIF
IF oError != NIL
IF lError
Break( oError )
ENDIF
RETURN .T.
FUNCTION __dbCreate( cFileName, cFileFrom, cRDDName, lNew, cAlias, cdpId, nConnection )
/* NOTE: Compared to CA-Cl*pper, Harbour has two extra parameters
(cCodePage, nConnection). */
FUNCTION __dbCreate( cFileName, cFileFrom, cRDD, lNew, cAlias, cCodePage, nConnection )
LOCAL nOldArea := Select()
LOCAL aStruct := {}
LOCAL oError
DEFAULT lNew TO .F.
IF Used() .AND. ! lNew
IF cAlias == NIL
hb_FNameSplit( cFileName, NIL, @cAlias )
ENDIF
IF Used() .AND. !lNew
dbCloseArea()
ENDIF
@@ -119,15 +128,13 @@ FUNCTION __dbCreate( cFileName, cFileFrom, cRDDName, lNew, cAlias, cdpId, nConne
{ "FIELD_TYPE", "C", 1, 0 },;
{ "FIELD_LEN" , "N", 3, 0 },;
{ "FIELD_DEC" , "N", 3, 0 } },;
cRDDName,,,, cdpId, nConnection )
dbUseArea( .F., cRDDName, cFileName, cAlias,,, cdpId, nConnection )
cRDD, .F., cAlias, NIL, cCodePage, nConnection )
ELSE
dbUseArea( lNew, NIL, cFileFrom, "" )
dbUseArea( lNew,, cFileFrom, "" )
dbEval( {|| AAdd( aStruct, { Rtrim(FIELD->FIELD_NAME) ,;
Rtrim(FIELD->FIELD_TYPE) ,;
/* ; Harbour does some extra RTrim()-ing here. */
dbEval( {|| AAdd( aStruct, { RTrim( FIELD->FIELD_NAME ) ,;
RTrim( FIELD->FIELD_TYPE ) ,;
FIELD->FIELD_LEN ,;
FIELD->FIELD_DEC } ) } )
dbCloseArea()
@@ -136,12 +143,11 @@ FUNCTION __dbCreate( cFileName, cFileFrom, cRDDName, lNew, cAlias, cdpId, nConne
dbSelectArea( nOldArea )
ENDIF
AEval( aStruct, {| aField | iif( aField[ DBS_TYPE ] == "C" .AND. aField[ DBS_DEC ] != 0, ;
( aField[ DBS_LEN ] += aField[ DBS_DEC ] * 256, ;
AEval( aStruct, {| aField | iif( aField[ DBS_TYPE ] == "C" .AND. aField[ DBS_DEC ] != 0,;
( aField[ DBS_LEN ] += aField[ DBS_DEC ] * 256,;
aField[ DBS_DEC ] := 0 ), NIL ) } )
dbCreate( cFileName, aStruct, cRDDName,,,, cdpId, nConnection )
dbUseArea( lNew, cRDDName, cFileName, cAlias,,, cdpId, nConnection )
dbCreate( cFileName, aStruct, cRDD, lNew, cAlias, NIL, cCodePage, nConnection )
ENDIF
@@ -178,8 +184,20 @@ FUNCTION __dbStructFilter( aStruct, aFieldList )
bFindName := {| aField | aField[ DBS_NAME ] == cName }
AEval( aFieldList, {| cFieldName, nIndex | ;
cName := RTrim( Upper( cFieldName ) ), ;
nIndex := aScan( aStruct, bFindName ),;
cName := RTrim( Upper( cFieldName ) ),;
nIndex := AScan( aStruct, bFindName ),;
iif( nIndex == 0, NIL, AAdd( aStructFiltered, aStruct[ nIndex] ) ) } )
RETURN aStructFiltered
#ifdef HB_COMPAT_XPP
/* Identical to __dbCopyStruct() */
FUNCTION dbCopyStruct( cFileName, aFieldList )
RETURN dbCreate( cFileName, __dbStructFilter( dbStruct(), aFieldList ) )
FUNCTION dbCopyExtStruct( cFileName )
RETURN __dbCopyXStruct( cFileName )
#endif

87
harbour/source/rdd/dbtotal.prg
View File

@@ -50,20 +50,22 @@
*
*/
#include "hbsetup.ch"
#include "common.ch"
#include "dbstruct.ch"
#include "error.ch"
/* NOTE: Compared to CA-Cl*pper, Harbour:
- will accept character expressions for xKey, xFor and xWhile.
- has two extra parameters (nConnection, cpdId).
- will defuault to active index key for xKey parameter.
- has more error handling.
*/
- has three extra parameters (cRDD, nConnection, cCodePage).
- will default to active index key for xKey parameter.
- won't crash with "No exported method: EVAL" if xKey is not
block and table is not indexed. */
FUNCTION __dbTotal( cFile, xKey, aFields, ;
xFor, xWhile, nNext, nRec, lRest, cRDD, ;
nConnection, cdpId )
FUNCTION __dbTotal( cFile, xKey, aFields,;
xFor, xWhile, nNext, nRec, lRest,;
cRDD, nConnection, cCodePage )
LOCAL nOldArea
LOCAL nNewArea
@@ -74,29 +76,29 @@ FUNCTION __dbTotal( cFile, xKey, aFields, ;
LOCAL lDbTransRecord
LOCAL xCurKey
LOCAL bKeyBlock
LOCAL bForBlock
LOCAL bWhileBlock
LOCAL bForBlock
LOCAL bKeyBlock
LOCAL lError := .F.
LOCAL bOldError
LOCAL oError
LOCAL lError := .F.
IF ValType( xWhile ) == "C"
IF ISCHARACTER( xWhile )
bWhileBlock := &("{||" + xWhile + "}")
ELSEIF ValType( xWhile ) != "B"
bWhileBlock := {|| .T. }
ELSE
lRest := .T.
ELSEIF ISBLOCK( xWhile )
bWhileBlock := xWhile
lRest := .T.
ELSE
bWhileBlock := {|| .T. }
ENDIF
IF ValType( xFor ) == "C"
IF ISCHARACTER( xFor )
bForBlock := &("{||" + xFor + "}")
ELSEIF ValType( xFor ) != "B"
bForBlock := {|| .T. }
ELSE
ELSEIF ISBLOCK( xFor )
bForBlock := xFor
ELSE
bForBlock := {|| .T. }
ENDIF
DEFAULT lRest TO .F.
@@ -123,35 +125,26 @@ FUNCTION __dbTotal( cFile, xKey, aFields, ;
RETURN .F.
ENDIF
bOldError := ErrorBlock( {| x | Break( x ) } )
BEGIN SEQUENCE
IF Empty( xKey )
xKey := IndexKey()
IF Empty( xKey )
oError := ErrorNew()
oError:description := "Invalid argument"
oError:genCode := EG_ARG
Break( oError )
ENDIF
xKey := ordKey()
ENDIF
IF ValType( xKey ) == "C"
IF ISCHARACTER( xKey )
bKeyBlock := &("{||" + xKey + "}")
ELSEIF ValType( xKey ) != "B"
bKeyBlock := {|| .T. }
ELSE
ELSEIF ISBLOCK( xKey )
bKeyBlock := xKey
ELSE
bKeyBlock := {|| .T. }
ENDIF
aGetField := {}
AEval( aFields, {| cField | AAdd( aGetField, GetField( cField ) ) } )
AEval( aFields, {| cField | AAdd( aGetField, __GetField( cField ) ) } )
aFieldsSum := Array( Len( aGetField ) )
// ; Keep it open after creating it.
dbCreate( cFile, aNewDbStruct, cRDD, .T., "", NIL, cdpId, nConnection )
/* ; Keep it open after creating it. */
dbCreate( cFile, aNewDbStruct, cRDD, .T., "", NIL, cCodePage, nConnection )
nNewArea := Select()
dbSelectArea( nOldArea )
@@ -188,7 +181,7 @@ FUNCTION __dbTotal( cFile, xKey, aFields, ;
RECOVER USING oError
lError := .T.
ENDSEQUENCE
END SEQUENCE
IF nNewArea != NIL
dbSelectArea( nNewArea )
@@ -196,25 +189,20 @@ FUNCTION __dbTotal( cFile, xKey, aFields, ;
ENDIF
dbSelectArea( nOldArea )
ErrorBlock( bOldError )
IF lError
IF ValType( oError:operation ) == "C"
oError:operation += "/__DBTOTAL"
ELSE
oError:operation := "__DBTOTAL"
ENDIF
Eval( ErrorBlock(), oError )
Break( oError )
ENDIF
RETURN .T.
STATIC FUNCTION GetField( cField )
STATIC FUNCTION __GetField( cField )
LOCAL nCurrArea := Select()
LOCAL nPos
LOCAL oError
LOCAL lError
/* ; Is the field aliased? */
IF ( nPos := At( "->", cField ) ) > 0
IF Select( Left( cField, nPos - 1 ) ) != nCurrArea
@@ -228,7 +216,7 @@ STATIC FUNCTION GetField( cField )
oError:subCode := 1101
lError := Eval( ErrorBlock(), oError )
IF ValType( lError ) != "L" .OR. lError
IF !ISLOGICAL( lError ) .OR. lError
__ErrInHandler()
ENDIF
@@ -243,3 +231,10 @@ STATIC FUNCTION GetField( cField )
FUNCTION __dbTransRec( nDstArea, aFieldsStru )
RETURN __dbTrans( nDstArea, aFieldsStru, NIL, NIL, 1 )
#ifdef HB_COMPAT_XPP
FUNCTION dbTotal( cFile, xKey, aFields, xFor, xWhile, nNext, nRec, lRest )
RETURN __dbTotal( cFile, xKey, aFields, xFor, xWhile, nNext, nRec, lRest )
#endif

13
harbour/source/rdd/dbupdat.prg
View File

@@ -50,6 +50,8 @@
*
*/
#include "hbsetup.ch"
#include "common.ch"
FUNCTION __dbUpdate( cAlias, bKey, lRandom, bAssign )
@@ -57,6 +59,7 @@ FUNCTION __dbUpdate( cAlias, bKey, lRandom, bAssign )
LOCAL xKey
LOCAL oError
LOCAL lError := .F.
DEFAULT lRandom TO .F.
@@ -90,12 +93,20 @@ FUNCTION __dbUpdate( cAlias, bKey, lRandom, bAssign )
ENDDO
RECOVER USING oError
lError := .T.
END SEQUENCE
dbSelectArea( nOldArea )
IF oError != NIL
IF lError
Break( oError )
ENDIF
RETURN .T.
#ifdef HB_COMPAT_XPP
FUNCTION dbUpdate( cAlias, bAssign, bKey, lRandom )
RETURN __dbUpdate( cAlias, bKey, lRandom, bAssign )
#endif

27
harbour/source/rdd/rddord.prg
View File

@@ -50,6 +50,8 @@
*
*/
#include "hbsetup.ch"
#include "common.ch"
#include "dbinfo.ch"
@@ -67,7 +69,7 @@ FUNCTION dbClearIndex()
FUNCTION dbReindex()
RETURN ordListRebuild()
FUNCTION dbSetOrder( nOrderNum )
PROCEDURE dbSetOrder( nOrderNum )
IF ISCHARACTER( nOrderNum ) .AND. !Empty( Val( nOrderNum ) )
nOrderNum := Val( nOrderNum )
@@ -75,7 +77,7 @@ FUNCTION dbSetOrder( nOrderNum )
ordSetFocus( nOrderNum )
RETURN NIL
RETURN
FUNCTION IndexExt()
RETURN ordBagExt()
@@ -92,18 +94,19 @@ FUNCTION IndexKey( nOrder )
RETURN ""
FUNCTION OrdSetRelation( xArea, bRelation, cRelation )
FUNCTION ordSetRelation( xArea, bRelation, cRelation )
RETURN dbSetRelation( xArea, bRelation, cRelation, .T. )
/* short (10 chars long) version of some ord* functions for compatibility */
FUNCTION ORDLISTCLE()
RETURN ORDLISTCLEAR()
/* NOTE: Undocumented Clipper function */
FUNCTION ORDLISTREB()
RETURN ORDLISTREBUILD()
#ifdef HB_C52_UNDOC
#ifdef HB_C52_STRICT
FUNCTION ORDSETFOCU( xOrder, cFile )
RETURN ORDSETFOCUS( xOrder, cFile )
FUNCTION _dtxCondSet( cFor, bFor, lAll, bWhile, bEval, nEvery, xDummy, nRecNo, nNext, nRecord, lRest )
FUNCTION ORDSETRELA( xArea, bRelation, cRelation )
RETURN ORDSETRELATION( xArea, bRelation, cRelation )
HB_SYMBOL_UNUSED( xDummy )
RETURN ordCondSet( cFor, bFor, lAll, bWhile, bEval, nEvery, nRecNo, nNext, nRecord, lRest )
#endif
#endif

351
harbour/source/rtl/Makefile
View File

@@ -5,185 +5,182 @@
ROOT = ../../
C_SOURCES=\
abs.c \
accept.c \
ampm.c \
at.c \
binnum.c \
binnumx.c \
box.c \
cdpapi.c \
chrasc.c \
colorind.c \
console.c \
copyfile.c \
datec.c \
dates.c \
dateshb.c \
datesx.c \
defpath.c \
descend.c \
dirdrive.c \
direct.c \
diskspac.c \
disksphb.c \
do.c \
empty.c \
errorapi.c \
errorint.c \
file.c \
filehb.c \
filesys.c \
fkmax.c \
fnsplit.c \
fserror.c \
fssize.c \
fstemp.c \
gete.c \
gt.c \
gtapi.c \
gtclip.c \
gtsys.c \
gttone.c \
gtfunc.c \
gx.c \
hardcr.c \
hbffind.c \
hbgtcore.c \
hbrandom.c \
idle.c \
inkey.c \
is.c \
isprint.c \
langapi.c \
left.c \
len.c \
lennum.c \
math.c \
maxrow.c \
memofile.c \
memoline.c \
minmax.c \
mlcount.c \
mlctopos.c \
mlpos.c \
mod.c \
mouseapi.c \
mousex.c \
mpostolc.c \
mtran.c \
natmsg.c \
net.c \
oemansi.c \
oldbox.c \
oldclear.c \
pad.c \
padc.c \
padl.c \
padr.c \
philes.c \
philes53.c \
philesx.c \
rat.c \
replic.c \
right.c \
round.c \
run.c \
samples.c \
saverest.c \
scroll.c \
seconds.c \
set.c \
setcolor.c \
setcurs.c \
setkey.c \
setpos.c \
setposbs.c \
shadow.c \
soundex.c \
space.c \
spfiles.c \
str.c \
strcase.c \
strings.c \
strmatch.c \
strpeek.c \
strtran.c \
strzero.c \
stuff.c \
substr.c \
teditorl.c \
tone.c \
trace.c \
transfrm.c \
trim.c \
type.c \
val.c \
valtostr.c \
valtype.c \
version.c \
word.c \
xhelp.c \
xsavescr.c \
abs.c \
accept.c \
ampm.c \
at.c \
binnum.c \
binnumx.c \
box.c \
cdpapi.c \
chrasc.c \
colorind.c \
console.c \
copyfile.c \
datec.c \
dates.c \
dateshb.c \
datesx.c \
defpath.c \
descend.c \
dirdrive.c \
direct.c \
diskspac.c \
disksphb.c \
do.c \
empty.c \
errorapi.c \
errorint.c \
file.c \
filehb.c \
filesys.c \
fkmax.c \
fnsplit.c \
fserror.c \
fssize.c \
fstemp.c \
gete.c \
gt.c \
gtapi.c \
gtclip.c \
gtsys.c \
gttone.c \
gtfunc.c \
gx.c \
hardcr.c \
hbffind.c \
hbgtcore.c \
hbrandom.c \
idle.c \
inkey.c \
is.c \
isprint.c \
langapi.c \
left.c \
len.c \
lennum.c \
math.c \
maxrow.c \
memofile.c \
memoline.c \
minmax.c \
mlcount.c \
mlctopos.c \
mlpos.c \
mod.c \
mouseapi.c \
mousex.c \
mpostolc.c \
mtran.c \
natmsg.c \
net.c \
oemansi.c \
oldbox.c \
oldclear.c \
pad.c \
padc.c \
padl.c \
padr.c \
philes.c \
philes53.c \
philesx.c \
rat.c \
replic.c \
right.c \
round.c \
run.c \
samples.c \
saverest.c \
scroll.c \
seconds.c \
set.c \
setcolor.c \
setcurs.c \
setkey.c \
setpos.c \
setposbs.c \
shadow.c \
soundex.c \
space.c \
spfiles.c \
str.c \
strcase.c \
strings.c \
strmatch.c \
strpeek.c \
strtran.c \
strzero.c \
stuff.c \
substr.c \
teditorl.c \
tone.c \
trace.c \
transfrm.c \
trim.c \
type.c \
val.c \
valtostr.c \
valtype.c \
version.c \
word.c \
xhelp.c \
xsavescr.c \
PRG_SOURCES=\
achoice.prg \
adir.prg \
altd.prg \
alert.prg \
browdb.prg \
browdbx.prg \
browse.prg \
checkbox.prg \
color53.prg \
dbdelim.prg \
dbedit.prg \
dbjoin.prg \
dbsdf.prg \
devoutp.prg \
dircmd.prg \
dummy.prg \
errorsys.prg \
fieldbl.prg \
getlist.prg \
getsys.prg \
input.prg \
listbox.prg \
memoedit.prg \
memvarbl.prg \
menuto.prg \
mssgline.prg \
objfunc.prg \
perfuncs.prg \
persist.prg \
profiler.prg \
pushbtn.prg \
radiobtn.prg \
radiogrp.prg \
readkey.prg \
readvar.prg \
scrollbr.prg \
setfunc.prg \
setta.prg \
symbol.prg \
tclass.prg \
tbcolumn.prg \
tbrowse.prg \
teditor.prg \
terror.prg \
text.prg \
tget.prg \
tgetint.prg \
tgetlist.prg \
tlabel.prg \
tmenuitm.prg \
tobject.prg \
tpopup.prg \
treport.prg \
ttextlin.prg \
ttopbar.prg \
typefile.prg \
wait.prg \
achoice.prg \
adir.prg \
altd.prg \
alert.prg \
browdb.prg \
browdbx.prg \
browse.prg \
checkbox.prg \
color53.prg \
dbedit.prg \
devoutp.prg \
dircmd.prg \
dummy.prg \
errorsys.prg \
fieldbl.prg \
getlist.prg \
getsys.prg \
input.prg \
listbox.prg \
memoedit.prg \
memvarbl.prg \
menuto.prg \
mssgline.prg \
objfunc.prg \
perfuncs.prg \
persist.prg \
profiler.prg \
pushbtn.prg \
radiobtn.prg \
radiogrp.prg \
readkey.prg \
readvar.prg \
scrollbr.prg \
setfunc.prg \
setta.prg \
symbol.prg \
tclass.prg \
tbcolumn.prg \
tbrowse.prg \
teditor.prg \
terror.prg \
text.prg \
tget.prg \
tgetint.prg \
tgetlist.prg \
tlabel.prg \
tmenuitm.prg \
tobject.prg \
tpopup.prg \
treport.prg \
ttextlin.prg \
ttopbar.prg \
typefile.prg \
wait.prg \
LIBNAME=rtl

440
harbour/source/rtl/dbdelim.prg
View File

@@ -1,440 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Copies the contents of a database to a delimited text file.
* Appends the contents of a delimited text file to a database.
*
* Copyright 2001-2003 David G. Holm <dholm@jsd-llc.com>
* www - http://www.harbour-project.org
* APPEND FROM code submitted by Marco Braida <marcobra@elart.it>
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* function __dbDelim() replaced by the new one which uses
* DELIM RDD I've just created
*
* 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.
*
*/
REQUEST DELIM
PROCEDURE __dbDelim( lExport, cFile, cDelimArg, aFields, bFor, bWhile, nNext, nRecord, lRest )
IF lExport
__dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "DELIM", , , cDelimArg )
ELSE
__dbApp( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "DELIM", , , cDelimArg )
ENDIF
RETURN
#ifdef __DBDELIM_STRICT_CLIPPER_CODE__
function __dbDelim( lExport, cFile, cDelimArg, aFields, bFor, bWhile, nNext, nRecord, lRest )
local nSrcArea, nDstArea, aStruct, cRDD := "DELIM"
if lExport
nSrcArea := Select()
else
nDstArea := Select()
endif
if Empty( aStruct := __fledit( dbstruct(), aFields ) )
return .F.
endif
if lExport
dbcreate( cFile, aStruct, cRDD, .T., "", cDelimArg )
nDstArea := Select()
if nDstArea == nSrcArea
nDstArea := Nil
endif
select( nSrcArea )
else
if !__dbopensdf( cFile, aStruct, cRDD, .T., "", cDelimArg )
return .F.
endif
nSrcArea := Select()
endif
if nDstArea != nil
__dbtrans( nDstArea, aStruct, bFor, bWhile, nNext, nRecord, lRest )
endif
if lExport
if nDstArea != Nil
select( nDstArea )
close
endif
select( nSrcArea )
else
select( nSrcArea )
close
select( nDstArea )
endif
return .T.
#endif /* __DBDELIM_STRICT_CLIPPER_CODE__ */
#ifdef __DBDELIM_OLD_CODE__
#include "hbcommon.ch"
#include "fileio.ch"
#include "error.ch"
#include "set.ch"
HB_FILE_VER( "$Id$" )
#define AppendEOL( handle ) FWRITE( handle, CHR( 13 ) + CHR( 10 ) )
#define AppendEOF( handle ) FWRITE( handle, CHR( 26 ) )
#define AppendSep( handle, cSep ) FWRITE( handle, cSep )
PROCEDURE __dbDelim( lExport, cFile, cDelimArg, aFields, bFor, bWhile, nNext, nRecord, lRest )
LOCAL index, handle, lWriteSep, cFileName := cFile, nStart, nCount, oErr
LOCAL cSeparator := ",", cDelim := CHR( 34 )
//------------------
local Pos:=0
local nPosFl:=0
local nDimBuff:=65535
local cByte :=""
local lunghezze:={}
local eol:=chr(13)+chr(10)
local contacamp:=0
local primariga:=.t.
local offset:=0
local rig:=0
local cont_r:=""
local Lfinefile:=.f.
local nFileLen
local cCharEol:=HB_OSNewLine()
local nLenEol:=LEN(cCharEol)
local nPosLasteol
local lcisonoeol
local lErrResult
//------------------
// Process the delimiter argument.
IF !EMPTY( cDelimArg )
IF UPPER( cDelimArg ) == "BLANK"
cDelim := ""
cSeparator := " "
ELSE
cDelim := LEFT( cDelimArg, 1 )
END IF
END IF
// Process the file name argument.
index := RAT( ".", cFileName )
IF index > 0
// The file name might include a file extension.
IF RAT( "/", cFileName ) > index ;
.OR. RAT( "\", cFileName ) > index
// No, the file extension is in a directory name.
index := 0
END IF
END IF
IF index <= 0
// No file name extension, so provide the default.
cFileName += ".txt"
END IF
// Determine where to start and how many records to process.
IF nRecord != NIL
// The RECORD clause has the highest priority.
nStart := nRecord
nCount := 1
ELSEIF nNext != NIL
// The NEXT clause has the next highest priority.
nStart := -1
nCount := nNext
ELSEIF bWhile != NIL .OR. lRest
// The WHILE and REST clauses have equal priority.
nStart := -1
nCount := -1
ELSE
// Followed by the FOR clause or the ALL clause.
nStart := 0
nCount := -1
END IF
IF EMPTY( bFor )
// This simplifies the test that determines whether or not to
// use (i.e., import or export) any given processed record.
bFor := {||.T.}
END IF
IF lExport
// COPY TO DELIMITED
IF !USED()
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_NOTABLE
oErr:subSystem := "DELIM"
oErr:subCode := 2001
oErr:description := HB_LANGERRMSG( oErr:genCode )
oErr:canRetry := .F.
oErr:canDefault := .T.
Eval(ErrorBlock(), oErr)
handle := -1
ELSE
WHILE ( handle := FCREATE( cFileName ) ) == -1
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_CREATE
oErr:subSystem := "DELIM"
oErr:subCode := 1002
oErr:description := HB_LANGERRMSG( oErr:genCode )
oErr:canRetry := .T.
oErr:canDefault := .T.
oErr:fileName := cFileName
oErr:osCode := FERROR()
lErrResult := Eval(ErrorBlock(), oErr)
IF VALTYPE( lErrResult ) != "L" .OR. !lErrResult
EXIT
ENDIF
ENDDO
ENDIF
IF handle != -1
IF nStart > -1
// Only reposition if a starting record was specified or implied.
IF nStart == 0
GO TOP
ELSE
GO (nStart)
END IF
END IF
IF EMPTY( bWhile )
// This simplifies the looping logic.
bWhile := {||.T.}
END IF
// Set up for the start of the first record.
lWriteSep := .F.
// Process the records to copy delimited.
WHILE EVAL( bWhile ) .AND. ( nCount == -1 .OR. nCount > 0 ) ;
.AND. !BOF() .AND. !EOF()
IF EVAL( bFor )
IF EMPTY( aFields )
// Process all fields.
FOR index := 1 TO FCOUNT()
IF lWriteSep
AppendSep( handle, cSeparator )
END IF
lWriteSep := ExportVar( handle, FIELDGET( index ), cDelim )
NEXT index
ELSE
// Process the specified fields.
FOR index := 1 TO LEN( aFields )
IF lWriteSep
AppendSep( handle, cSeparator )
END IF
lWriteSep := ExportVar( handle, FIELDGET( FIELDPOS( aFields[ index ] ) ), cDelim )
NEXT index
END IF
// Set up for the start of the next record.
AppendEOL( handle )
lWriteSep := .F.
END IF
IF nCount != -1
nCount--
END IF
SKIP
END WHILE
IF SET(_SET_EOF)
AppendEOF( handle )
END IF
FCLOSE( handle )
END IF
ELSE
// APPEND FROM DELIMITED
handle := FOPEN( cFileName )
IF handle == -1
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_OPEN
oErr:subSystem := "DELIM"
oErr:subCode := 1001
oErr:description := HB_LANGERRMSG( oErr:genCode )
oErr:canRetry := .T.
oErr:canDefault := .T.
oErr:fileName := cFileName
oErr:osCode := FERROR()
Eval(ErrorBlock(), oErr)
ELSE
IF EMPTY( bWhile )
// This simplifies the looping logic.
bWhile := {||.T.}
ENDIF
// ---------------------------------------
// Please fill with the other test here
// Marco Braida 2002
// marcobra@elart.it
// ---------------------------------------
nFileLen:=FSEEK(handle,0,FS_END)
nDimBuff:=min(nFileLen,nDimBuff)
cByte:=space(nDimBuff)
FSEEK(handle,0)
// cCharEol:=chr(13)
nPosLastEol:=0
do while .not. lFineFile
fseek(handle,nPoslastEol,FS_SET) // forward the pointer
//we must not go after the eof
if nPosLastEol + nDimBuff > nFileLen
// change the buffer size
nDimBuff:=nFileLen-nPosLastEol
cByte:=space(nDimBuff)
Lfinefile:=.t.
endif
// fill the buffer
cByte:=space(nDimBuff)
fread(handle,@cByte,nDimBuff)
// with +1 there is a problem on large import of data
// for now we keep it remmed
// please test and test and test
nPoslastEol+=rat(cCharEol,cByte) // +1
//do this if in the buffer there are eol char
lcisonoeol:=.t.
do while lcisonoeol
// the position of the first eol
nposfl:=at(cCharEol,cByte)
lcisonoeol:=(nPosfl>0)
if lcisonoeol
// cut the row
Pos:=1
cont_r:=substr(cByte,Pos,nposfl-Pos)
appendtodb(cont_r,cSeparator,cDelim)
// skipping the line feed and now we are on a good char
pos:=nposfl+nLenEol
cont_r:=""
//cut the row
cByte:=substr(cByte,Pos)
endif
enddo
enddo
FCLOSE( handle )
END IF
END IF
RETURN
STATIC FUNCTION ExportVar( handle, xField, cDelim )
DO CASE
CASE VALTYPE( xField ) == "C"
FWRITE( handle, cDelim + TRIM( xField ) + cDelim )
CASE VALTYPE( xField ) == "D"
FWRITE( handle, DTOS( xField ) )
CASE VALTYPE( xField ) == "L"
FWRITE( handle, iif( xField, "T", "F" ) )
CASE VALTYPE( xField ) == "N"
FWRITE( handle, LTRIM( STR( xField ) ) )
OTHERWISE
RETURN .F.
END CASE
RETURN .T.
STATIC FUNCTION appendtodb(row,cSeparator,cDelim)
local lenrow:=len(row)
local aStruct:=DBSTRUCT()
local aMyVal:={}
local ii:=1
local nPosSep:=0, nPosNextSep:=0
local nDBFFields
local cBuffer, cUPbuffer
local vRes
local nPos1Deli, nPos2Deli
//if there is one field only there is no Separator and i put...
row:=row+cSeparator
nPosSep:=1
nPosNextSep:=at(cSeparator,row) // seek the first Separator eg. ,
nPos1Deli:=at(cDelim,row) // seek the first delimiter "
nPos2Deli:=at(cDelim+cSeparator,row,nPos1Deli+1) // seek the second delimiter "
if nPos1Deli > 0 .and. nPos2Deli > 0
if nPosNextSep>nPos1Deli .and. nPosNextSep<nPos2Deli
nPosSep:=nPos1Deli
nPosNextSep=nPos2Deli+1
endif
endif
aadd( aMyval,substr(row,nPosSep,nPosNextSep-1) )
nPosSep:=nPosNextSep
do while .t.
nPosNextSep:=at(cSeparator,row,nPosSep+1)
if nPosNextSep=0
exit
endif
nPos1Deli:=at(cDelim,row,nPosSep) // seek the first delimiter "
nPos2Deli:=at(cDelim+cSeparator,row,nPos1Deli+1) // seek the second delimiter "
if nPos1Deli > 0 .and. nPos2Deli > 0
if nPosNextSep>nPos1Deli .and. nPosNextSep<nPos2Deli
nPosSep=nPos1Deli
nPosNextSep=nPos2Deli+1
endif
endif
aadd( aMyVal,substr(row,nPosSep+1,nPosnextSep-nPosSep-1) )
nPosSep:=nPosNextSep
if nPosSep>lenrow
exit
endif
enddo
nDBFfields:=min(len(aMyVal),len(aStruct))
append blank
for ii:=1 to nDBFfields
cBuffer:=strtran(aMyval[ii],cDelim,'')
DO CASE
CASE aStruct[ ii,2 ] == "D"
vRes := HB_STOD( cBuffer )
CASE aStruct[ ii,2 ] == "L"
cUPbuffer:=upper(cBuffer)
vRes := iif( cUPBuffer == "T" .or. cUPBuffer== "1" .or. cUPBuffer=="Y",.T.,.F. )
CASE aStruct[ ii,2 ] == "N"
vRes := VAL( cBuffer )
OTHERWISE
vRes := cBuffer
END CASE
FIELDPUT(ii,vRes)
next
return .T.
#endif /* __DBDELIM_OLD_CODE__ */

144
harbour/source/rtl/dbjoin.prg
View File

@@ -1,144 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* __DBJOIN() function
*
* Copyright 2005 Pavel Tsarenko <tpe2@mail.ru>
* www - http://www.harbour-project.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.
*
*/
Function __dbJoin( cAlias, cFile, aFields, bFor, cRdd, nConnection, cdpId )
Local nMaster := Select()
Local nDetail := Select(cAlias)
Local nResult, aStruct, aJoinList, oError, lError := .F.
Select(nMaster)
if ( Empty(aStruct := FieldTwo(cAlias, aFields)) )
return .F.
endif
begin sequence
dbCreate(cFile, aStruct, cRdd, .T., "", , cdpId, nConnection)
nResult := Select()
aJoinList := __JoinList(nMaster, nDetail, nResult, aStruct)
Select(nMaster)
go top
do while ! Eof()
Select(nDetail)
go top
do while ! Eof()
Select(nMaster)
if Eval(bFor)
__doJoinList(aJoinList)
endif
Select(nDetail)
skip
enddo
Select(nMaster)
Skip
enddo
recover using oError
lError := .T.
end sequence
if nResult != nil
Select(nResult)
close
endif
Select(nMaster)
if lError
break( oError )
endif
return .T.
static function FieldTwo( cAlias, aFields )
Local aFldTemp, bFind, cField, aStruct
if Empty(aFields)
return dbStruct()
endif
aFldTemp := {}
AEval(aFields, { |cFld| AAdd(aFldTemp, Trim(Upper(cFld))) })
aFields := aFldTemp
aStruct := {}
bFind := { |c| c == cField }
AEval(dbStruct(), { |a| ( cField := a[1], iif( ascan(aFields, bFind) == 0,;
nil, AAdd(aStruct, a) ) ) })
select(cAlias)
bFind := { |cFld| "->" $ cFld .AND. SubStr(cFld, At("->", cFld) + 2) == ;
cField }
AEval(dbStruct(), { |a| ( cField := a[ 1 ], iif( AScan(aFields, bFind) == 0,;
nil, AAdd(aStruct, a) ) ) })
return aStruct
static function __JoinList(nMaster, nDetail, nResult, aStruct)
Local i, aList := {}, nPos
for i := 1 to len(aStruct)
if ( nPos := (nMaster)->(FieldPos(aStruct[i][1])) ) # 0
AAdd(aList, {nResult, nMaster, nPos, i})
elseif ( nPos := (nDetail)->(FieldPos(aStruct[i][1])) ) # 0
AAdd(aList, {nResult, nDetail, nPos, i})
endif
next
Return aList
static function __doJoinList(aList)
local aJoin
if len(aList) > 0
( aList[1][1] )->( dbAppend() )
for each aJoin in aList
( aJoin[1] )->(FieldPut( aJoin[4], ( aJoin[2] )->(FieldGet( aJoin[3] )) ))
next
endif
return nil

309
harbour/source/rtl/dbsdf.prg
View File

@@ -1,309 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Copies the contents of a database to an SDF text file.
* Appends the contents of an SDF text file to a database.
*
* Copyright 2001-2002 David G. Holm <dholm@jsd-llc.com>
* www - http://www.harbour-project.org
*
* Copyright 2006 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* function __dbSDF() replaced by the new one which uses
* SDF RDD I've just created
*
* 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.
*
*/
#include "hbcommon.ch"
#include "fileio.ch"
#include "error.ch"
#include "set.ch"
HB_FILE_VER( "$Id$" )
REQUEST SDF
PROCEDURE __dbSDF( lExport, cFile, aFields, bFor, bWhile, nNext, nRecord, lRest )
IF lExport
__dbCopy( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "SDF" )
ELSE
__dbApp( cFile, aFields, bFor, bWhile, nNext, nRecord, lRest, "SDF" )
ENDIF
RETURN
#ifdef __DBSDF_OLD_CODE__
#define SkipEOL( handle ) FSEEK( handle, nEOLSize, FS_RELATIVE )
#define AppendEOL( handle ) FWRITE( handle, HB_OSNewLine() )
#define AppendEOF( handle ) FWRITE( handle, CHR( 26 ) )
PROCEDURE __dbSDF( lExport, cFile, aFields, bFor, bWhile, nNext, nRecord, lRest )
LOCAL index, handle, cFileName := cFile, nStart, nCount, oErr, nFileLen, aStruct
LOCAL cFileEOL:=chr(13)+chr(10) // EOL defaults to windows
LOCAL nEOLSize:=2 // EOL size default to windows
// Process the file name argument.
index := RAT( ".", cFileName )
IF index > 0
// The file name might include a file extension.
IF RAT( "/", cFileName ) > index ;
.OR. RAT( "\", cFileName ) > index
// No, the file extension is in a directory name.
index := 0
END IF
END IF
IF index <= 0
// No file name extension, so provide the default.
cFileName += ".txt"
END IF
// Determine where to start and how many records to process.
IF nRecord != NIL
// The RECORD clause has the highest priority.
nStart := nRecord
nCount := 1
ELSEIF nNext != NIL
// The NEXT clause has the next highest priority.
nStart := -1
nCount := nNext
ELSEIF bWhile != NIL .OR. lRest
// The WHILE and REST clauses have equal priority.
nStart := -1
nCount := -1
ELSE
// Followed by the FOR clause or the ALL clause.
nStart := 0
nCount := -1
END IF
IF EMPTY( bFor )
// This simplifies the test that determines whether or not to
// use (i.e., import or export) any given processed record.
bFor := {||.T.}
END IF
IF lExport
// COPY TO SDF
handle := FCREATE( cFileName )
IF handle == -1
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_CREATE
oErr:subSystem := "SDF"
oErr:subCode := 1002
oErr:description := HB_LANGERRMSG( oErr:genCode )
oErr:canRetry := .T.
oErr:canDefault := .T.
oErr:fileName := cFileName
oErr:osCode := FERROR()
Eval(ErrorBlock(), oErr)
ELSE
IF nStart > -1
// Only reposition if a starting record was specified or implied.
IF nStart == 0
GO TOP
ELSE
GO (nStart)
END IF
END IF
IF EMPTY( bWhile )
// This simplifies the looping logic.
bWhile := {||.T.}
END IF
// Process the records to copy SDF.
WHILE EVAL( bWhile ) .AND. ( nCount == -1 .OR. nCount > 0 ) ;
.AND. !BOF() .AND. !EOF()
IF EVAL( bFor )
IF EMPTY( aFields )
// Process all fields.
FOR index := 1 TO FCOUNT()
ExportFixed( handle, FIELDGET( index ) )
NEXT index
ELSE
// Process the specified fields.
FOR index := 1 TO LEN( aFields )
ExportFixed( handle, FIELDGET( FIELDPOS( aFields[ index ] ) ) )
NEXT index
END IF
// Set up for the start of the next record.
AppendEOL( handle )
END IF
IF nCount != -1
nCount--
END IF
SKIP
END WHILE
IF SET(_SET_EOF)
AppendEOF( handle )
END IF
FCLOSE( handle )
END IF
ELSE
// APPEND FROM SDF
handle := FOPEN( cFileName )
IF handle == -1
oErr := ErrorNew()
oErr:severity := ES_ERROR
oErr:genCode := EG_OPEN
oErr:subSystem := "SDF"
oErr:subCode := 1001
oErr:description := HB_LANGERRMSG( oErr:genCode )
oErr:canRetry := .T.
oErr:canDefault := .T.
oErr:fileName := cFileName
oErr:osCode := FERROR()
Eval(ErrorBlock(), oErr)
ELSE
cFileEOL:=FindEOL(handle)
nEOLSize:=len(cFileEOL)
IF EMPTY( bWhile )
// This simplifies the looping logic.
bWhile := {||.T.}
END IF
nFileLen := FSEEK( handle,0,FS_END )
FSEEK( handle,0 )
aStruct := DBSTRUCT()
WHILE FSEEK( handle,0,FS_RELATIVE ) + 1 < nFileLen
APPEND BLANK
IF EMPTY( aFields )
// Process all fields.
FOR index := 1 TO FCOUNT()
IF !ImportFixed( handle,index,aStruct, cFileEOL )
EXIT
ENDIF
NEXT index
ELSE
// Process the specified fields.
FOR index := 1 TO LEN( aFields )
IF !ImportFixed( handle,FIELDPOS( aFields[ index ] ),aStruct, cFileEOL )
EXIT
ENDIF
NEXT index
END IF
// Set up for the start of the next record.
SkipEOL( handle )
END WHILE
FCLOSE( handle )
END IF
END IF
RETURN
STATIC FUNCTION ExportFixed( handle, xField )
DO CASE
CASE VALTYPE( xField ) == "C"
FWRITE( handle, xField )
CASE VALTYPE( xField ) == "D"
FWRITE( handle, DTOS( xField ) )
CASE VALTYPE( xField ) == "L"
FWRITE( handle, iif( xField, "T", "F" ) )
CASE VALTYPE( xField ) == "N"
FWRITE( handle, STR( xField ) )
OTHERWISE
RETURN .F.
END CASE
RETURN .T.
STATIC FUNCTION ImportFixed( handle, index, aStruct, cFileEOL )
LOCAL cBuffer := Space(aStruct[ index,3 ]), pos, res := .T., nRead
LOCAL vres
nRead := FREAD( handle, @cBuffer, aStruct[ index,3 ] )
IF ( pos := At( cFileEOL,cBuffer ) ) > 0 .AND. pos <= nRead
res := .F.
FSEEK( handle, -( nRead - pos + 1 ), FS_RELATIVE )
IF pos > 1
cBuffer := Left( cBuffer,pos-1 )
ELSE
RETURN res
ENDIF
ENDIF
DO CASE
CASE aStruct[ index,2 ] == "D"
vres := HB_STOD( cBuffer )
CASE aStruct[ index,2 ] == "L"
vres := iif( cBuffer == "T",.T.,.F. )
CASE aStruct[ index,2 ] == "N"
vres := VAL( cBuffer )
OTHERWISE
vres := cBuffer
END CASE
FIELDPUT( index, vres )
RETURN res
STATIC FUNCTION FindEOL(fh)
LOCAL nBufSize:=512
LOCAL cBuffer:=space(nBufSize)
LOCAL nF:=0,c:='',cResult:=''
fseek(fh,0,FS_SET)
do while fread(fh,@cBuffer,nBufSize) > 0
do while nF <= nBufSize
c:=substr(cBuffer,nF,1)
IF c==chr(10) // Unix type EOL
cResult := chr(10)
ELSEIF c==chr(13) // MSWIN or MAC
if substr(cBuffer,nF+1,1)==chr(10)
cResult := (chr(13)+chr(10))
else
cResult := chr(13)
endif
ENDIF
if len(cResult)>0
fseek(fh,0,FS_SET)
RETURN cResult
endif
++nF
enddo
enddo
fseek(fh,0,FS_SET)
if len(cResult)==0
// TODO: Report an error - can't find EOL
endif
RETURN cResult
#endif /* __DBSDF_OLD_CODE__ */

14
harbour/source/rtl/tbrowse.prg
View File

@@ -181,8 +181,8 @@ CLASS TBrowse
METHOD PosCursor() // Positions the cursor to the beginning of the call, used only when autolite==.F.
METHOD LeftDetermine() // Determine leftmost unfrozen column in display
METHOD DispCell( nRow, nCol, nMode ) // Displays a single cell and returns cell type as a single letter like Valtype()
METHOD HowManyCol( nWidth ) // Counts how many cols can be displayed
METHOD RedrawHeaders( nWidth ) // Repaints TBrowse Headers
METHOD HowManyCol() // Counts how many cols can be displayed
METHOD RedrawHeaders() // Repaints TBrowse Headers
METHOD Moved() // Every time a movement key is issued I need to reset certain properties
// of TBrowse, I do these settings inside this method
@@ -846,9 +846,10 @@ return Self
// Calculate how many columns fit on the browse width including ColSeps
METHOD HowManyCol( nWidth ) CLASS TBrowse
METHOD HowManyCol() CLASS TBrowse
local nToAdd
local nWidth := ::nRight - ::nLeft + 1
// They were locals, so now I need to clear them (should fix this)
::nColsWidth := 0
@@ -912,13 +913,14 @@ return Self
// Gets TBrowse width and width of displayed columns plus colsep
METHOD RedrawHeaders( nWidth ) CLASS TBrowse
METHOD RedrawHeaders() CLASS TBrowse
local n, nTPos, nBPos
local cBlankBox := Space(9)
local nScreenRowT
local nScreenRowB
local nLCS // Len(ColSep)
local nWidth := ::nRight - ::nLeft + 1
if ::lHeaders // Drawing headers
@@ -1038,8 +1040,8 @@ METHOD Stabilize() CLASS TBrowse
if ::lRedrawFrame
// How may columns fit on TBrowse width?
::HowManyCol( nWidth )
::RedrawHeaders( nWidth )
::HowManyCol()
::RedrawHeaders()
// Now that browser frame has been redrawn we don't need to redraw it unless
// displayed columns change

17
harbour/source/rtl/typefile.prg
View File

@@ -50,13 +50,15 @@
*
*/
#include "hbsetup.ch"
#include "common.ch"
#include "error.ch"
#include "fileio.ch"
#define BUFFER_LENGTH 2048
FUNCTION __TYPEFILE( cFile, lPrint )
PROCEDURE __TypeFile( cFile, lPrint )
LOCAL nHandle, cBuffer, nRead := 0, nHasRead := 0, nSize := 0, nBuffer
LOCAL oErr, xRecover, nRetries
LOCAL aSaveSet[ 2 ]
@@ -91,7 +93,7 @@ FUNCTION __TYPEFILE( cFile, lPrint )
cTmp := hb_FNameMerge( aPath[ i ], cName, cExt )
IF file( cTmp )
cFile := cTmp
exit
EXIT
ENDIF
NEXT
ENDIF
@@ -110,7 +112,7 @@ FUNCTION __TYPEFILE( cFile, lPrint )
oErr:tries := ++nRetries
xRecover := Eval( ErrorBlock(), oErr )
IF ISLOGICAL( xRecover ) .and. !xRecover // user select "Default"
RETURN NIL
RETURN
ENDIF
ENDDO
@@ -145,7 +147,7 @@ FUNCTION __TYPEFILE( cFile, lPrint )
Set( _SET_PRINTER, aSaveSet[ 2 ] )
ENDIF
RETURN NIL
RETURN
/*----------------------------------------------------------------------------*/
/* Function aDvd : Divide string to tokens and put tokens into array */
@@ -167,3 +169,10 @@ STATIC FUNCTION aDvd( cString, cDelim )
AAdd( aProm, cString )
RETURN aProm
#ifdef HB_COMPAT_XPP
FUNCTION _TypeFile( cFile, lPrint )
RETURN __TypeFile( cFile, lPrint )
#endif

96
harbour/source/vm/arrayshb.c
View File

@@ -332,99 +332,3 @@ HB_FUNC( HB_APARAMS )
{
hb_itemRelease( hb_itemReturn( hb_arrayFromParams( hb_parni( 1 ) + 1 ) ) );
}
HB_FUNC( HB_AEXPRESSIONS )
{
PHB_ITEM pArray = hb_stackReturnItem();
PHB_ITEM pLine = hb_param( 1, HB_IT_STRING );
size_t i, iOffset = 0;
int iParans = 0, iArrays = 0, iIndexs = 0;
BOOL bArray = FALSE;
if( pLine == NULL )
{
hb_errRT_BASE_SubstR( EG_ARG, 9999, NULL, "HB_AEXPRESSIONS", HB_ERR_ARGS_BASEPARAMS );
return;
}
hb_arrayNew( pArray, 0 );
for( i = 0; i < pLine->item.asString.length; i++ )
{
switch( pLine->item.asString.value[i] )
{
case '(' :
iParans++;
bArray = FALSE;
break;
case ')' :
iParans--;
bArray = TRUE;
break;
case '{' :
iArrays++;
bArray = FALSE;
break;
case '}' :
iArrays--;
bArray = TRUE;
break;
case '[' :
if( bArray || ( i && isalnum((int) pLine->item.asString.value[i - 1] ) ) )
{
iIndexs++;
}
else
{
while( ++i < pLine->item.asString.length && pLine->item.asString.value[i] != ']' );
}
bArray = FALSE;
break;
case ']' :
iIndexs--;
bArray = TRUE;
break;
case '"' :
while( ++i < pLine->item.asString.length && pLine->item.asString.value[i] != '"' );
bArray = FALSE;
break;
case '\'' :
while( ++i < pLine->item.asString.length && pLine->item.asString.value[i] != '\'' );
bArray = FALSE;
break;
case ',' :
if( iParans == 0 && iArrays == 0 && iIndexs == 0 )
{
PHB_ITEM pExp = hb_itemNew( NULL );
hb_arrayAdd( pArray, hb_itemPutCL( pExp, pLine->item.asString.value + iOffset, i - iOffset ) );
iOffset = i + 1;
hb_itemRelease( pExp );
}
bArray = FALSE;
break;
default :
bArray = FALSE;
break;
}
}
if( iOffset < pLine->item.asString.length - 1 )
{
PHB_ITEM pExp = hb_itemNew( NULL );
hb_arrayAdd( pArray, hb_itemPutCL( pExp, pLine->item.asString.value + iOffset, pLine->item.asString.length - iOffset ) );
hb_itemRelease( pExp );
}
}

1
harbour/utils/Makefile
View File

@@ -6,6 +6,7 @@ ROOT = ../
DIRS=\
hbpp \
hbpptest \
hbver \
hbrun \
hbdoc \

28
harbour/utils/hbpptest/pretest.prg
View File

@@ -1,6 +1,10 @@
//
// $Id$
//
/*
* $Id$
*/
#ifndef __HARBOUR__
#xtranslate HB_OSNewLine() => ( Chr( 13 ) + Chr( 10 ) )
#endif
#command TEXT TO VAR <v> => #pragma __stream|%s||<v>:=
#command CTEXT TO VAR <v> => #pragma __cstream|%s||<v>:=
@@ -958,9 +962,9 @@ ENDTEXT
/* ---------------------------------------------------------------------*/
__PP_FREE()
? "Total count =", nCnt
? "Valid results =", nRes
? "Failed results=", nCnt - nRes
OutStd( "Total count =", nCnt, hb_OSNewLine() )
OutStd( "Valid results =", nRes, hb_OSNewLine() )
OutStd( "Failed results=", nCnt - nRes, hb_OSNewLine() )
RETURN
@@ -994,15 +998,15 @@ LOCAL i
IF( pre == out )
RETURN 1
ELSE
? pre
? out
? " => FAILED in LINE: ", PROCLINE(1)
OutStd( pre, hb_OSNewLine() )
OutStd( out, hb_OSNewLine() )
OutStd( " => FAILED in LINE: ", PROCLINE(1), hb_OSNewLine() )
i := 1
WHILE SUBSTR(pre,i,1) == SUBSTR(out,i,1)
i++
ENDDO
? SUBSTR( pre, i )
? SUBSTR( out, i )
OutStd( SUBSTR( pre, i ), hb_OSNewLine() )
OutStd( SUBSTR( out, i ), hb_OSNewLine() )
ENDIF
RETURN 0
RETURN 0