/*
* Proyecto: HDO_GENERAL
* Fichero: ej17.prg
* Descripcion:
* Autor: Manu Exposito 2014-18
* Fecha: 10/09/2018
*/
//------------------------------------------------------------------------------
#include "hdo.ch"
#include "inkey.ch"
//------------------------------------------------------------------------------
// Desmarcar el RDL con el que se desea trabajar
#define _RDLSQLITE
//#define _RDLMYSQL
//------------------------------------------------------------------------------
#ifdef _RDLSQLITE
REQUEST RDLSQLITE
#define _DBMS "sqlite"
#define _DB "hdodemo.db"
#define _CONN
#endif
#ifdef _RDLMYSQL
#include "hdomysql.ch"
REQUEST RDLMYSQL
#define _DBMS "mysql"
#define _DB "hdodemo"
#define _CONN "127.0.0.1", "root", "root"
#endif
//------------------------------------------------------------------------------
// Definiciones
#define B_BOX ( CHR( 218 ) + CHR( 196 ) + CHR( 191 ) + CHR( 179 ) + ;
CHR( 217 ) + CHR( 196 ) + CHR( 192 ) + CHR( 179 ) + " " )
// Sentencias precompiladas:
#define STMT_SEL "SELECT * FROM test WHERE idreg BETWEEN ? AND ?;"
#define STMT_INS "INSERT INTO test ( first, last, street, city, state, zip, hiredate, married, age, salary, notes ) VALUES ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"
#define STMT_UPD "UPDATE test SET first = ?, last = ?, street = ?, city = ?, state = ?, zip = ?, hiredate = ?, married = ?, age = ?, salary = ?, notes = ? WHERE idreg = ?;"
#define STMT_DEL "DELETE FROM test WHERE idreg = ?;"
//------------------------------------------------------------------------------
// Variables estaticas que se van a usar en varias funciones
static oDb, oRS // Objeto conexion y RowSet
static idreg, first, last, street, city, state, zip, hiredate, married, ;
age, salary, notes // Variables de campos
static nRecIni, nRecEnd // Valor inicial y final
//------------------------------------------------------------------------------
// Procedimiento principal
procedure main17
local e, i, getlist := {}
////////////////////////////////////////////////////////////////////////////////
// Esto no tiene efectos si no se usa el sistema embebido //
////////////////////////////////////////////////////////////////////////////////
#ifdef _RDLMYSQL //
local aOptions := { "HDO_DEMO", "--defaults-file=./my.cnf" } //
local aGroup := { "server", "client" } //
//----------------------------------------------------------------------------//
initMySQLEmdSys( aOptions, aGroup, "client" ) //
#endif //
////////////////////////////////////////////////////////////////////////////////
set date format to "dd-mm-yyyy"
oDb := THDO():new( _DBMS )
#ifdef _RDLMYSQL
// Necesario para que ping() funcione tradicionalmente (reconecte)
oDb:setAttribute( MYSQL_OPT_RECONNECT, .t. )
// MYSQL_INIT_COMMAND ejecuta un comando al establecer la conexion
//oDb:setAttribute( MYSQL_INIT_COMMAND, "CREATE TABLE lolo LIKE test;" )
#endif
if oDb:connect( _DB, _CONN )
//oDb:exec( "set session wait_timeout = 10" )
// Si se quieren establecer atributos por defecto a nivel de conexion o
// base de datos hay que hacerlo antes de abrir las consultas del tipo
// que sean:
oDb:setAttribute( HDO_ATTR_DEFAULT_STR_PAD, .t. )
oDb:setAttribute( HDO_ATTR_DEFAULT_TINY_AS_BOOL, .t. )
try
// oRS := oDb:rowSet( STMT_SEL )
oRS := TRowSet():new( oDb, STMT_SEL )
/*
// Prueba de setAttribute y getAttribute
msg( oRS:getAttribute( STMT_ATTR_STR_PAD ), "STMT_ATTR_STR_PAD" )
oRS:setAttribute( STMT_ATTR_STR_PAD, .f. )
msg( oRS:getAttribute( STMT_ATTR_STR_PAD ), "STMT_ATTR_STR_PAD" )
msg( oRS:getAttribute( STMT_ATTR_TINY_AS_BOOL ), "STMT_ATTR_TINY_AS_BOOL" )
oRS:setAttribute( STMT_ATTR_TINY_AS_BOOL, .t. )
msg( oRS:getAttribute( STMT_ATTR_TINY_AS_BOOL ), "STMT_ATTR_TINY_AS_BOOL" )
msg( oRS:getAttribute( STMT_ATTR_CURSOR_TYPE ), "STMT_ATTR_CURSOR_TYPE" )
oRS:setAttribute( STMT_ATTR_CURSOR_TYPE, CURSOR_TYPE_READ_ONLY )
msg( oRS:getAttribute( STMT_ATTR_CURSOR_TYPE ), "STMT_ATTR_CURSOR_TYPE" )
msg( oRS:getAttribute( STMT_ATTR_PREFETCH_ROWS ), "STMT_ATTR_PREFETCH_ROWS" )
oRS:setAttribute( STMT_ATTR_PREFETCH_ROWS, 100 )
msg( oRS:getAttribute( STMT_ATTR_PREFETCH_ROWS ), "STMT_ATTR_PREFETCH_ROWS" )
msg( oRS:getAttribute( STMT_ATTR_UPDATE_MAX_LENGTH ), "STMT_ATTR_UPDATE_MAX_LENGTH" )
oRS:setAttribute( STMT_ATTR_UPDATE_MAX_LENGTH, .f. )
msg( oRS:getAttribute( STMT_ATTR_UPDATE_MAX_LENGTH ), "STMT_ATTR_UPDATE_MAX_LENGTH" )
*/
oRS:bindParam( 1, @nRecIni )
oRS:bindParam( 2, @nRecEnd )
// Asignamos las sentencias del mantenimiento de tablas
oRS:setInsertStmt( STMT_INS )
oRS:setUpdateStmt( STMT_UPD )
oRS:setDeleteStmt( STMT_DEL )
nRecIni := 0
nRecEnd := 9999999
menu()
// Un filtro: todo los apellidos "Klein"
//oRS:setFilter( { || AllTrim( oRS:fieldGet( "last" ) ) == "Klein" } )
while inkey( 0 ) != 27
cls
@ 02, 02 SAY "Entrada de datos:"
@ 04, 02 SAY "Entre rango inicial..................:" GET nRecIni PICTURE "@K 99999999"
@ 05, 02 SAY "Entre rango final....................:" GET nRecEnd PICTURE "@K 99999999" VALID validaRango( nRecIni, nRecEnd )
READ
e := Seconds()
oRS:load()
msg( Seconds() - e )
oRS:goTop()
cabecera()
Pie()
miBrw()
menu()
// Otro filtro: todos los registros del año 1990
//oRS:setFilter( { || oRS:fieldGet( 8 ) > CToD( "31-12-1989" ) .and. oRS:fieldGet( 8 ) < CToD( "01-01-1991" ) } )
end
catch e
eval( errorBlock(), e )
finally
if ValType( oRS ) == 'O'
oRS:free()
end
end
endif
oDb:disconnect()
msg( "--- < FIN > ---" )
return
//------------------------------------------------------------------------------
// Browse para el objeto RowSet
static procedure miBrw()
local i, oBrw := tbrowsenew( 2, 1, maxrow() -1 , maxcol() - 1 )
hb_dispbox( 1, 0, maxrow() - 1, maxcol(), hb_utf8tostrbox( "┌─â”│┘─└│ " ), "W+/B, N/BG" )
oBrw:colorSpec := "W+/B, N/BG"
oBrw:ColSep := hb_utf8tostrbox( "│" )
oBrw:HeadSep := hb_utf8tostrbox( "┼─" )
oBrw:FootSep := hb_utf8tostrbox( "┴─" )
oBrw:GoTopBlock := {|| oRS:goTop() }
oBrw:GoBottomBlock := {|| oRS:goBottom() }
oBrw:SkipBlock := {| nSkip | oRS:skipper( nSkip ) }
genColumn( oBrw )
frontControl( oBrw )
return
//------------------------------------------------------------------------------
// Controlador de opciones
static procedure frontControl( oBrw )
while .t.
oBrw:forceStable()
switch inkey()
case K_ESC // Salir
setpos( maxrow(), 0 )
return
case K_DOWN // Fila siguiente
oBrw:Down()
exit
case K_UP // Fila anterior
oBrw:Up()
exit
case K_LEFT // Va a la columna antrior
oBrw:left()
exit
case K_RIGHT // Va a la columna siguiente
oBrw:right()
exit
case K_PGDN // Va a la pagina siguiente
oBrw:pageDown()
exit
case K_PGUP // Va a la pagina antrior
oBrw:pageUp()
exit
case K_CTRL_PGUP // Va al principio
oBrw:goTop()
exit
case K_CTRL_PGDN // Va al final
oBrw:goBottom()
exit
case K_HOME // Va a la primera columna visible
oBrw:home()
exit
case K_END // Va a la ultima columna visible
oBrw:end()
exit
case K_CTRL_LEFT // Va a la primera columna
oBrw:panLeft()
exit
case K_CTRL_RIGHT // Va a la ultima columna
oBrw:panRight()
exit
case K_CTRL_HOME // Va a la primera página
oBrw:panHome()
exit
case K_CTRL_END // Va a la última página
oBrw:panEnd()
exit
case K_DEL // Borra fila
Borrar()
cabecera()
oBrw:refreshAll()
exit
case K_INS // Inserta columna
if Insertar( oBrw )
oBrw:goBottom()
endif
cabecera()
exit
case K_ENTER // Modifica columna
Modificar()
cabecera()
oBrw:refreshAll()
exit
case K_F1
ayuda()
exit
case K_F2
consultar()
exit
case K_F6
Buscar()
exit
case K_F9
ListarRS()
exit
end switch
end
return
//==============================================================================
// Funciones del browse
//------------------------------------------------------------------------------
// Genera las columnad del browse
static procedure genColumn( oBrw )
oBrw:AddColumn( tbcolumnnew( "#Reg.", { || oRS:fieldget( 1 ) } ) )
oBrw:AddColumn( tbcolumnnew( "First", { || oRS:fieldget( 2 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Last", { || oRS:fieldget( 3 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Street", { || oRS:fieldget( 4 ) } ) )
oBrw:AddColumn( tbcolumnnew( "City", { || oRS:fieldget( 5 ) } ) )
oBrw:AddColumn( tbcolumnnew( "State", { || oRS:fieldget( 6 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Zip", { || oRS:fieldget( 7 ) } ) )
#ifdef _RDLSQLITE
oBrw:AddColumn( tbcolumnnew( "Hiredate", { || HB_CToD( oRS:fieldget( 8 ), "yyyy-mm-dd" ) } ) )
oBrw:AddColumn( tbcolumnnew( "Married", { || if( oRS:fieldGet( 9 ) == 1, 'S', 'N' ) } ) )
#else
oBrw:AddColumn( tbcolumnnew( "Hiredate", { || oRS:fieldget( 8 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Married", { || if( oRS:fieldGet( 9 ), 'S', 'N' ) } ) )
#endif
oBrw:AddColumn( tbcolumnnew( "Age", { || oRS:fieldget( 10 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Salary", { || oRS:fieldget( 11 ) } ) )
oBrw:AddColumn( tbcolumnnew( "Notes", { || oRS:fieldget( 12 ) } ) )
return
//------------------------------------------------------------------------------
// Muestra una pequeñ¡ ¡yuda de uso de teclas por la la pantalla
static procedure ayuda()
#ifdef _RDLSQLITE
local cRDL := "RDL SQLITE;"
#else
local cRDL := "RDL MYSQL;"
#endif
msg( "---------------------;" + ;
cRDL + ;
"---------------------;;" + ;
"F1 ...... Ayuda ;" + ;
"F2 ...... Consultar ;" + ;
"F6 ...... Buscar ;" + ;
"F9 ...... Listar RS ;" + ;
"F10 ..... Listar Stmt;" + ;
"Intro ... Modificar ;" + ;
"Insert .. Insertar ;" + ;
"Supr .... Borrar " , "AYUDA" )
return
//------------------------------------------------------------------------------
// Opcion para modificar un registro
static procedure modificar()
local getList
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
cls
DispBox( 3, 2, 18, 74, B_BOX )
cargaReg()
@ 04, 03 SAY "Modificacion del socio: " + hb_ntos( idreg )
getList := muestraGet()
read
if lastkey() != K_ESC .and. updated()
married := if( married $ 'Ss', .t., .f. )
msgEspera()
oRS:update( { first, last, street, city, state, zip, hiredate, married, age, salary, notes, idreg }, .t. )
endif
restscreen( 0, 0, maxrow(), maxcol(), cSs )
return
//------------------------------------------------------------------------------
// Inserta un nuevo registro
static function Insertar( oBrw )
local getlist := {}
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
local lRet := .f.
oRS:goTo( 0 )
cargaReg()
cls
DispBox( 3, 2, 18, 74, B_BOX )
@ 04, 03 SAY "Alta de nuevo socio"
getlist := muestraGet()
read
if lastkey() != K_ESC .and. updated()
married := if( married $ 'Ss', .t., .f. )
msgEspera()
lRet := oRS:insert( { first, last, street, city, state, zip, hiredate, married, age, salary, notes }, .t. )
endif
restscreen( 0, 0, maxrow(), maxcol(), cSs )
return lRet
//------------------------------------------------------------------------------
// Opcion para consultar un registro
static procedure consultaInterna()
DispBox( 3, 2, 18, 74, B_BOX )
@ 04, 03 SAY "Consulta del socio [" + hb_ntos( oRS:fieldGet( 1 ) ) + "]"
@ 06, 03 SAY "First....: " + oRS:fieldGet( "First" ) //2 )
@ 07, 03 SAY "Last.....: " + oRS:fieldGet( "Last" ) //3 )
@ 08, 03 SAY "Street...: " + oRS:fieldGet( 4 )
@ 09, 03 SAY "City.....: " + oRS:fieldGet( 5 )
@ 10, 03 SAY "State....: " + oRS:fieldGet( 6 )
@ 11, 03 SAY "Zip......: " + oRS:fieldGet( 7 )
#ifdef _RDLSQLITE
@ 12, 03 SAY "Hiredate.: " + HB_DToC( HB_CToD( oRS:fieldGet( 8 ), "yyyy-mm-dd" ), "dd-mm-yyyy" )
@ 13, 03 SAY "Married..: " + if( oRS:fieldGet( 9 ) == 1, 'S', 'N' )
#else
@ 12, 03 SAY "Hiredate.: " + DToC( oRS:fieldGet( 8 ) )
@ 13, 03 SAY "Married..: " + if( oRS:fieldGet( 9 ), 'S', 'N' )
#endif
@ 14, 03 SAY "Age......: " + HB_NToS( oRS:fieldGet( 10 ) )
@ 15, 03 SAY "Salary...: " + HB_NToS( oRS:fieldGet( 11 ) )
@ 16, 03 SAY "Notes: "
@ 17, 03 SAY oRS:fieldGet( 12 )
return
//------------------------------------------------------------------------------
static procedure consultar()
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
cls
consultaInterna()
espera()
restscreen( 0, 0, maxrow(), maxcol(), cSs )
return
//------------------------------------------------------------------------------
// Borra un registro
static procedure Borrar()
local getList := {}
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
local cSN := "N"
cls
consultaInterna()
@ 20, 03 SAY "Realmente quieres borrar este registro?" GET cSN PICTURE "@K" VALID cSN $ "SsNn"
READ
restscreen( 0, 0, maxrow(), maxcol(), cSs )
if ( cSN $ "Ss" )
msgEspera()
oRS:delete( { oRS:fieldGet( 1 ) }, .t. )
endif
return
//------------------------------------------------------------------------------
// Busca un registro uso del metodo find y findNext
//
// oRS:find( valor, num_columna, desde_el_principio )
// Parametros:
// valor: parametro que contiene el valor que se quiera buscar, puede ser de
// cualquier tipo
// num_columna: numero de columna en la que se debe buscar el valor
// desde_el_principio: BOOL indica si empieza desde el principio
static procedure Buscar()
local s, n
local nCol := 1, xVal := Space( 30 )
local getList := {}
local nRec := oRS:recNo()
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
cls
@ 02, 02 SAY "Introduce la columna por la que buscar...:" GET nCol PICTURE "@K 99"
READ
// xVal := oRS:fieldGet( nCol )
@ 03, 02 SAY "Valor de [" + oRS:fieldName( nCol ) + "] que quiere buscar...:" GET xVal PICTURE "@K"
READ
cls
n := 0 // Reutilizo variable
if ( s := oRS:findString( xVal, nCol, .t. ) ) > 0
? Replicate( "-", MaxCol() )
? "Hallado el valor [", oRS:fieldGet( nCol ), "] de la columna:", oRS:fieldName( nCol )
? Replicate( "-", MaxCol() )
while s > 0
n++
? "Registro numero:", oRS:recNo(), oRS:fieldGet( nCol )
s := oRS:findStringNext() // Busca siguiente
end
? Replicate( "-", MaxCol() )
? "Hay", AllTrim( Str( n ) ), "ocurrencias de", xVal, "en la columna", AllTrim( Str( nCol ) )
? Replicate( "-", MaxCol() )
else
? xVal, "no encontrado..."
endif
espera( 30 )
oRS:goTo( nRec )
restscreen( 0, 0, maxrow(), maxcol(), cSs )
return
//------------------------------------------------------------------------------
// Consulta directamente a la tabla con variables xbase vinculadas
static procedure ListarRS()
local i := 1
local cSs := savescreen( 0, 0, maxrow(), maxcol() )
local nRec := oRS:recNo()
oRS:goTop()
cls
? "Registros desde la tabla:"
while !oRS:eof()
? HB_NToS( oRS:fieldGet( 1 ) ), oRS:fieldGet( 2 ), oRS:fieldGet( 3 ), oRS:fieldGet( 4 )
oRS:next()
if( i > 20, ( espera(), Scroll(), SetPos( 0, 0 ), i := 1 ), i++ )
end while
oRS:goTo( nRec )
msg( "Se termino..." )
restscreen( 0, 0, maxrow(), maxcol(), cSs )
return
//------------------------------------------------------------------------------
static procedure menu()
cls
@ maxrow(), 00 SAY "Presiona <INTRO> para selecionar rangos o <ESC> para salir..."
return
//------------------------------------------------------------------------------
// Muestra cabecera
static procedure cabecera()
@ 00, 00 SAY "RDL: " + oDb:getAttribute( HDO_ATTR_RDL_NAME ) + PadR( " | Base de Datos: " + oDb:getDBName() + ;
" | La consulta tiene " + ;
hb_ntos( oRS:rowCount() ) + " registros", MaxCol() + 1, " " ) color "W+/R"
return
//------------------------------------------------------------------------------
// Muestra pie
static procedure pie()
@ maxrow(), 00 SAY PadR( "<F1> Ayuda - <ESC> para ir al menu inicial...", ;
MaxCol() + 1, " " ) color "W+/R"
return
//------------------------------------------------------------------------------
//
static procedure msgEspera()
@ MaxRow() - 1, 01 SAY "Actualizando la tabla con los cambios. Espere un momento..."
return
//==============================================================================
// Otras funciones
//------------------------------------------------------------------------------
// Muestra los GET por pantalla y devuelve el array getList
static function muestraGet()
local getList := {}
@ 06, 03 SAY "First....:" GET first PICTURE "@K"
@ 07, 03 SAY "Last.....:" GET last PICTURE "@K"
@ 08, 03 SAY "Street...:" GET street PICTURE "@K"
@ 09, 03 SAY "City.....:" GET city PICTURE "@K"
@ 10, 03 SAY "State....:" GET state PICTURE "@K"
@ 11, 03 SAY "Zip......:" GET zip PICTURE "@K 99999-9999"
@ 12, 03 SAY "Hiredate.:" GET hiredate PICTURE "@KD"
@ 13, 03 SAY "Married..:" GET married PICTURE "@K" VALID married $ "SsNn"
@ 14, 03 SAY "Age......:" GET age PICTURE "@K 999"
@ 15, 03 SAY "Salary...:" GET salary PICTURE "@K 999999.99"
@ 16, 03 SAY "Notes:"
@ 17, 03 GET notes PICTURE "@K"
return getList
//------------------------------------------------------------------------------
// Carga el actual registro del actual del cursor a las variables de campos
static procedure cargaReg()
// Se puede usar tambien con la posicion: idreg := oRS:fieldGet( 1 )
idreg := oRS:fieldGet( "idreg" )
first := oRS:fieldGet( "first" )
last := oRS:fieldGet( "last" )
street := oRS:fieldGet( "street" )
city := oRS:fieldGet( "city" )
state := oRS:fieldGet( "state" )
zip := oRS:fieldGet( "zip" )
#ifdef _RDLSQLITE
hiredate := HB_CToD( oRS:fieldGet( "hiredate" ), "yyyy-mm-dd" )
married := if( oRS:fieldGet( "married" ) == 1, 'S', 'N' )
#else
hiredate := oRS:fieldGet( "hiredate" )
married := if( oRS:fieldGet( "married" ), "S", "N" )
#endif
age := oRS:fieldGet( "age" )
salary := oRS:fieldGet( "salary" )
notes := oRS:fieldGet( "notes" )
//muestra( oRS:getValuesAsHash() )
return
//------------------------------------------------------------------------------
// Valida el rango entre dos valores
static function validaRango( r1, r2 )
local lRet := ( r2 >= r1 )
if !lRet
msg( "El riemer rango debe ser mayor que segundo:; " + ;
hb_ntos( r1 ) + " > " + ;
hb_ntos( r2 ), "Error en rangos" )
endif
return lRet
//------------------------------------------------------------------------------
