As a special gift from Santa (thanks Jose Luis!) here you have it to start using it. It has been tested with Harbour in PC and Pocket PC. Your feedback is welcome
Code: Select all
#include "fivewin.ch"
#include "dbinfo.ch"
function main()
local o, x, nSec, n := 0, a[100], b
REQUEST HB_LANG_ES // Para establecer español para Mensajes, fechas, etc..
REQUEST HB_CODEPAGE_ESMWIN // Para establecer código de página a Español
(Ordenación, etc..)
REQUEST DBFCDX //&&,DBFCDX
REQUEST DBFFPT
RDDSETDEFAULT("DBFCDX")
SET AUTOPEN OFF
SET DELETED ON
SET CENTURY ON
SET EPOCH TO( Year(Date())-50 )
SET DATE BRITISH // Formato dd-mm-aaaa
SET EXCLUSIVE OFF
SET SOFTSEEK OFF
HB_LangSelect('ES')
HB_SetCodePage("ESMWIN") // Para ordenación (arrays, cadenas, etc..)
msginfo("Iniciamos")
o := xDatabase() // Nueva clase derivada de tDatabase de fivewin
o:New( "CLI01.dbf")
o:lShared := .F.
o:Open()
o:lBuffer := .f.
nSec := Seconds()
// Test de velocidad en lectura de datos. Ahorro aproximado del 50%
nSec := Seconds()
for x=1 to 1000000
uFunc( o:Codpro )
next
Msginfo(Seconds()-nSec, "Test de lectura de datos")
// Test de velocidad en lectura con movimientos
nSec := Seconds()
for x=1 to 10000
o:Gotop()
Do while !o:Eof()
uFunc( o:Codpro )
o:Skip()
Enddo
next
Msginfo(Seconds()-nSec, "Test de lectura")
// Test de velocidad en Escritura
nSec := Seconds()
for x=1 to 10000
o:Gotop()
Do while !o:Eof()
o:Codpro := "Proba" + Alltrim(Str(x))
o:Skip()
Enddo
next
Msginfo(Seconds()-nSec, "Test de escritura")
return NIL
FUNCTION uFunc(u);Return NIL
////////////////////////////////////////////////////////////////////////////
/
CLASS xDatabase FROM tDatabase
METHOD SetArea()
METHOD Load()
METHOD CancelUpdate() INLINE ::lBuffer := .F.
MESSAGE FieldGet METHOD _FieldGet( nField )
MESSAGE FieldPut METHOD _FieldPut( nField, uVal )
METHOD Blank()
METHOD Modified()
METHOD SaveBuff()
MESSAGE OemToAnsi METHOD _OemToAnsi()
METHOD HashAddMember()
ERROR HANDLER ONERROR( uParam1 )
ENDCLASS
METHOD SetArea( nWorkArea ) CLASS xDatabase
local n, oClass, aDatas := {}, aMethods := {}
::nArea = nWorkArea
::cAlias = Alias( nWorkArea )
::cFile = Alias( nWorkArea )
if ::Used()
::cFile = ( nWorkArea )->( DbInfo( DBI_FULLPATH ) )
::cDriver = ( nWorkArea )->( RddName() )
::lShared = ( nWorkArea )->( DbInfo( DBI_SHARED ) )
#ifdef __HARBOUR__
::lReadOnly = ( nWorkArea )->( DbInfo( DBI_ISREADONLY ) )
#else
DEFAULT ::lReadOnly := .f.
#endif
DEFAULT ::lBuffer := .t.
DEFAULT ::lOemAnsi := .f.
DEFAULT ::bNetError := { || MsgStop( "Record in use", "Please, retry"
) }
::aStruct = ( ::cAlias )->( DbStruct() )
::aFldNames = {}
::aBuffer := hb_HSetCaseMatch( hb_Hash(), .F. )
for n = 1 to ( ::cAlias )->( FCount() )
AAdd( ::aFldNames, ( ::cAlias )->( FieldName( n ) ) )
::HashAddMember( {( ::cAlias )->( FieldName( n ) )},;
( ::cAlias )->( FieldType( n ) ),;
( ::cAlias )->( FieldGet( n ) ),;
::aBuffer )
next
hb_HSetAutoAdd( ::aBuffer, .f. )
if ::lOemAnsi
::OemToAnsi()
endif
#ifdef __XPP__
if ClassObject( Alias() ) == nil
ClassCreate( Alias(), { TDataBase() }, aDatas, aMethods )
// else
// ::this = Self
endif
#endif
endif
return Self
METHOD _FieldGet( nPos ) CLASS xDataBase
if ::lBuffer
//return ::aBuffer[ nPos ]
Return HB_HVALUEAT( ::aBuffer, nPos )
else
return ( ::nArea )->( FieldGet( nPos ) )
endif
return nil
//--------------------------------------------------------------------------
-//
METHOD _FieldPut( nPos, uValue ) CLASS xDataBase
local lLocked := .f.
if ::lBuffer
//::aBuffer[ nPos ] := uValue
HB_HVALUEAT( ::aBuffer, nPos, uValue )
else
if ::lShared
if ! ::lReadOnly
if ::IsRecLocked( ::RecNo() ) .or. ( lLocked := ::RecLock(
::RecNo() ) )
( ::nArea )->( FieldPut( nPos, uValue ) )
if lLocked
::Commit()
::RecUnLock( ::RecNo() )
endif
else
if ! Empty( ::bNetError )
return Eval( ::bNetError, Self )
endif
endif
endif
else
( ::nArea )->( FieldPut( nPos, uValue ) )
endif
endif
return nil
METHOD Load() CLASS xDataBase
local n
if ::lBuffer
for n = 1 to ( ::cAlias )->( FCount() )
::aBuffer[ ::aFldNames[n] ] := ( ::cAlias )->( FieldGet( n ) )
next
if ::lOemAnsi
::OemToAnsi()
endif
endif
return nil
//--------------------------------------------------------------------------
--//
METHOD Modified() CLASS XDataBase
local n
if ::lBuffer
for n := 1 to Len( ::aFldNames )
if ! ( ::cAlias )->( FieldGet( n ) ) == ::aBuffer[ ::aFldNames[n] ]
return .t.
endif
next
endif
return .f.
METHOD Blank() CLASS XDataBase
LOCAL a := HB_HKEYS( ::aBuffer )
if ::lBuffer
AEval( a, { |u,i| HB_HVALUEAT( ::aBuffer, i, uValBlank( u )) } )
endif
return .f.
METHOD _OemToAnsi() CLASS XDataBase
local n
for n = 1 to Len( ::aFldNames )
if ValType( ::aBuffer[ ::aFldNames[n] ] ) == "C"
::aBuffer[ ::aFldNames[n] ] := OemToAnsi( ::aBuffer[ ::aFldNames[n]
] )
endif
next
return nil
METHOD SaveBuff() CLASS XDataBase
local n
if ::lBuffer
for n := 1 to Len( ::aFldNames )
if ::lOemAnsi .and. ValType( ::aBuffer[ ::aFldNames[n] ] ) == "C"
( ::nArea )->( FieldPut( n, AnsiToOem( ::aBuffer[ ::aFldNames[n]
] ) ) )
else
( ::nArea )->( FieldPut( n, ::aBuffer[ ::aFldNames[n] ] ) )
endif
next
endif
return nil
****************************************************************************
************************************
* Descripción :
* Parámetros : Ninguno
* Fecha : 06/21/06
* Autor : Equipo de desarrollo de Aicom
****************************************************************************
************************************
METHOD HashAddMember( aName, cType, uInit, oObj ) CLASS xDataBase
//--------------------------------------------------------------------------
------------------------------------
local cName
if !( cType == nil )
switch Upper( Left( cType, 1 ) )
case "S" // STRING
if uInit == nil
uInit := ""
endif
exit
case "N" // NUMERIC
if uInit == nil
uInit := 0
endif
exit
case "L" // LOGICAL
if uInit == nil
uInit := .f.
endif
exit
case "D" // DATE
if uInit == nil
uInit := CtoD( "" )
endif
exit
case "C" // CODEBLOCK
if uInit == nil
uInit := { || nil }
endif
exit
case "A" // ARRAY
if uInit == nil
uInit := {}
endif
exit
end switch
endif
return NIL
#pragma BEGINDUMP
#include "windows.h"
#include "hbapi.h"
#include "hbapierr.h"
#include "hbapiitm.h"
#include "hbapicls.h"
#include "hbvm.h"
#include "hbdate.h"
#include "hboo.ch"
#include "hbapirdd.h"
#include "hbstack.h"
#include "hbapilng.h"
char * AicomGetmessage();
HB_FUNC_STATIC( XDATABASE_ONERROR )
{
char * cMessage = AicomGetmessage() ;
PHB_ITEM pSelf = hb_stackSelfItem();
BOOL bBuffer = hb_itemGetL( hb_objSendMsg(pSelf, "LBUFFER",
0) );
PHB_ITEM pValue = hb_param(1,HB_IT_ANY);
const char *cKey = ( *cMessage == '_' ? (cMessage+1) :
cMessage ) ;
if( bBuffer)
{
PHB_ITEM pHash = hb_objSendMsg(pSelf,"ABUFFER",0);
PHB_ITEM pKey = hb_itemPutC( hb_itemNew(NULL), cKey );
if( *cMessage == '_' )
{
// Con esto asignamos un valor al buffer
if( pHash && pKey && pValue )
{
hb_hashAdd( pHash, pKey, pValue );
hb_itemRelease( pKey );
}
else
hb_errRT_BASE( EG_ARG, 1123, NULL,
HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
} else
{
// Esto devuelve el valor del buffer
PHB_ITEM pDest = hb_hashGetItemPtr( pHash, pKey,
HB_HASH_AUTOADD_ACCESS );
hb_itemRelease( pKey );
if(pDest)
hb_itemReturn(pDest);
else
hb_errRT_BASE( EG_BOUND, 1132, NULL,
hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pHash, pValue );
}
}
else
{
int iAreaAnt = hb_rddGetCurrentWorkAreaNumber();
// Area anterior
int iAreaAct = hb_itemGetNI( hb_objSendMsg(pSelf,
"NAREA", 0 ) ); // Buscamos actual
AREAP pArea = ( AREAP )
hb_rddGetCurrentWorkAreaPointer(); // Necesitamos pArea
USHORT uiField = hb_rddFieldIndex( pArea, cKey );
// FieldPos ( cFieldName )
hb_rddSelectWorkAreaNumber( iAreaAct ) ;
// Seleccionamos area actual
if(uiField)
{
if( *cMessage == '_' )
{
// Asignamos el valor
if( pValue && !HB_IS_NIL( pValue ) )
{
if( SELF_PUTVALUE( pArea, uiField,
pValue ) == SUCCESS )
{
hb_itemReturn( pValue );
}
}
} else
{
// Devolvemos el valor del campo
PHB_ITEM pItem = hb_itemNew( NULL );
if( pArea ) // && uiField )
{
SELF_GETVALUE( pArea, uiField, pItem
);
}
hb_itemReturnRelease( pItem );
}
hb_rddSelectWorkAreaNumber( iAreaAnt ) ;
// Seleccionamos area anterior
} else
{
hb_errRT_DBCMD(( *cMessage == '_' ? 1005 : 1004 ),
0, "Field not found", cKey );
}
}
}
char * AicomGetmessage()
{
// Thanks to Przemek
long lOffset = hb_stackBaseProcOffset( 0 );
char * cMessage = (char *)hb_itemGetSymbol( hb_stackItem( lOffset ) )->szName;
return cMessage ;
}
