FiveTech Software tech support forums

www.FiveTechSoft.com
https://fivetechsoft.com/forums/

Una Clase TDataBase mucho más rápida !!!

https://fivetechsoft.com/forums/viewtopic.php?f=6&t=14021

Page 1 of 1

Una Clase TDataBase mucho más rápida !!!

Posted: Fri Dec 19, 2008 1:11 pm
by Antonio Linares
Jose Luis Capel de la empresa Aicom ha mejorado enormemente la velocidad de la Clase TDataBase de FiveWin haciéndola unas tres veces más rápida !!!

Como un regalo especial de Santa Claus (gracias Jose Luis!) aqui la teneis para empezar a usarla. Ha sido probada con Harbour en PC y en el Pocket PC. Se agradecen vuestras pruebas y resultados :-)

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 ; 
}

Posted: Fri Dec 19, 2008 11:47 pm
by joseluisysturiz
Muchas gracias Antonio y a el tocayo Jose Luis, empiezo a probarla...saludos... :shock:

Re: Una Clase TDataBase mucho más rápida !!!

Posted: Thu Jan 08, 2009 4:41 pm
by tosko
Esta Classe funciona con Xharbour ?
Gracias de antemano

Re: Una Clase TDataBase mucho más rápida !!!

Posted: Thu Jan 08, 2009 6:59 pm
by Antonio Linares
Por el momento, Jose Luis Capel, solo la ha probado con Harbour.

Nosotros hemos optado, de momento, por modificar la Clase TDataBase de FWH y eliminar el AScan() que se usa en el:

Code: Select all

   ...
         if( ( nField := ::FieldPos( SubStr( cMsg, 2 ) ) ) != 0 )
            ::FieldPut( nField, uParam1 )
         else
            _ClsSetError( _GenError( nError, ::ClassName(), SubStr( cMsg, 2 ) ) )
         endif
    ...

Re: Una Clase TDataBase mucho más rápida !!!

Posted: Thu Jan 15, 2009 10:56 pm
by ruben Dario
Como descargo esta clase, hay algun link o apartir de que version de fivewin esta incluida..

Re: Una Clase TDataBase mucho más rápida !!!

Posted: Thu Jan 15, 2009 10:59 pm
by Antonio Linares
Ruben,

En FWH 8.12 lo que hemos hecho ha sido quitar la llamada a AScan() para ganar en velocidad, como hemos explicado en esta conversacion.
All times are UTC
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited