/* * Xailer source code: * * DataSource.prg * Clase TDataSource() * * Copyright 2003, 2007 Ignacio Ortiz de Zúñiga * Copyright 2003, 2007 Xailer.com * All rights reserved * */ #include "Xailer.ch" #include "Language.ch" #include "error.ch" STATIC aDataSources := {} //-------------------------------------------------------------------------- FUNCTION DataSources( aDS ) // --> aDataSources LOCAL aOldDS := aDataSources IF PCount() > 0 aDataSources := aDS ENDIF RETURN aOldDS //-------------------------------------------------------------------------- CLASS XDataSource FROM TComponent PUBLISHED: PROPERTY cConnect INIT "" WRITE SetConnect EDITOR PE_WideString PROPERTY nTimeOut INIT 30 PROPERTY lAbortOnErrors INIT .F. PROPERTY lDisplayErrors INIT .T. PROPERTY lConnected INIT .F. WRITE INLINE IIf( Value, ::Connect(), ::DisConnect() ) EVENT OnCreate( oSender ) // --> Nil EVENT OnConnect( oSender ) // --> Nil EVENT OnConnected( oSender ) // --> Nil EVENT OnDisconnect( oSender ) // --> Nil EVENT OnDisconnected( oSender ) // --> Nil EVENT OnError( oSender, oError, oDataset ) // --> lResult | Nil EVENT OnExecute( oSender, cSql ) PUBLIC: DATA aDataSet INIT {} AS TDataSet RESERVED: DATA lUseDictionary INIT .F. //PROTECTED: CLASSDATA cProcess INIT "General" DATA aErrors INIT {} METHOD SetConnect( cConnect ) PUBLIC: METHOD New( oParent, cConnect ) CONSTRUCTOR METHOD Create( oParent, cConnect ) CONSTRUCTOR METHOD Destroy() // Creación de DataSets METHOD AddDataSet( oDataSet ) // --> Nil METHOD DelDataSet( oDataSet ) // --> lSuccess // Manejo de procesos METHOD NewProcess( cProcess ) INLINE ::cProcess := cProcess // --> Nil METHOD OpenProcess( cProcess ) // --> lSuccess METHOD CloseProcess( cProcess ) // --> Nil METHOD DelProcess( cProcess ) // --> nClosed METHOD EndProcess( cProcess ) INLINE ::DelProcess( cProcess ) // --> nClosed METHOD GetDataSet( cName, cProcess ) // --> oDataSet | Nil // Conexion METHOD Connect( cConn ) INLINE ( ::OnConnect(), ::FlConnected := .T., ::OnConnected(), .T. ) // --> .T. METHOD DisConnect() INLINE ( ::OnDisconnect(), ::FlConnected := .F., ::OnDisconnected() ) // --> Nil METHOD BuildSQLSt( cSql, xParams ) // --> cString METHOD SqlInsert( oRecord, cTable, lOnlyMod ) // --> cSql METHOD SqlUpdate( oRecord, cTable, lOnlyMod ) // --> cSql // Consulta de datos METHOD Table( cTableName, cProcess ) VIRTUAL METHOD Query( cCommand, cProcess ) VIRTUAL METHOD QueryReport( cCommand, cProcess ) VIRTUAL METHOD QueryArray( cCommand, aHeaders ) VIRTUAL METHOD QueryRow( cCommand, aHeaders, aDefault ) VIRTUAL METHOD QueryValue( cCommand, uDefault ) VIRTUAL METHOD RunProc( oProc ) VIRTUAL METHOD RunProcDirect( cProcName, uParams ) // --> uValue METHOD QueryMemDataset( cCommand, cProcess, oMemRS ) METHOD Execute( cCommand, cOperation, nOptions, oRS ) VIRTUAL METHOD BeginTrans() VIRTUAL METHOD CommitTrans() VIRTUAL METHOD RollBackTrans() VIRTUAL METHOD File( cName ) VIRTUAL METHOD GetTables( cMask, lViews ) VIRTUAL METHOD DelTable( cTable ) VIRTUAL METHOD GetCatalogs() VIRTUAL METHOD DToSql( dValue ) INLINE DToSql( dValue ) METHOD GetDateSql( dValue ) INLINE GetDateSql( dValue ) // Control de errores METHOD IsError() INLINE ( Len( ::aErrors ) > 0 ) // --> lResult METHOD LastError() INLINE IIf( Len( ::aErrors ) > 0, ATail( ::aErrors )[ 2 ], "" ) // --> cString METHOD DelErrors() INLINE ::aErrors := {} // --> Nil METHOD GetErrors() INLINE ::aErrors // --> aErrors METHOD ShowErrorList( cTitle ) // --> Nil RESERVED: METHOD NewError( cError, nError, oDataSet, cName ) METHOD NewDataSet( cName, cProcess ) METHOD ShowMasiveError( oDataSet ) METHOD OnOpen( oDataSet ) VIRTUAL METHOD OnOpened( oDataSet ) VIRTUAL METHOD GetRecords( oDataset, lForTable ) VIRTUAL METHOD StrSql( cString ) ENDCLASS //-------------------------------------------------------------------------- METHOD New( oParent, cConnect ) CLASS XDataSource ::Super:New( oParent ) UPDATE ::cConnect TO cConnect AAdd( aDataSources, Self ) IF ::oParent != Nil ::oParent:InsertComponent( Self ) ENDIF RETURN Self //-------------------------------------------------------------------------- METHOD Create( oParent, cConnect ) CLASS XDataSource IF !::lCreated ::Super:Create( oParent ) UPDATE ::cConnect TO cConnect IF Ascan( aDatasources, {|v| v == Self } ) == 0 AAdd( aDataSources, Self ) ENDIF IF ::oParent != Nil ::oParent:InsertComponent( Self ) ENDIF ::OnCreate() ENDIF RETURN Self //-------------------------------------------------------------------------- METHOD Destroy( lFree ) CLASS XDataSource LOCAL oDS, nAt DEFAULT lFree TO .F. IF ::lConnected ::DisConnect() ENDIF FOR EACH oDS IN ::aDataset WITH OBJECT oDS IF :lCreated IF IsDebug() logdebug( "Object " + :Classname + " (" + :cName + ") not destroyed correctly." ) ELSE // Para que se vean las perdidas de memoria :Destroy( lFree ) ENDIF ENDIF END WITH NEXT ::aDataSet := {} nAt := AScan( aDataSources, { |v| v == Self } ) IF nAt > 0 ADel( aDataSources, nAt ) ASize( aDataSources, Len( aDataSources ) - 1 ) ENDIF IF ::oParent != Nil ::oParent:RemoveComponent( Self ) ENDIF RETURN ::Super:Destroy( lFree ) //-------------------------------------------------------------------------- METHOD NewDataSet( cName, cProcess ) CLASS XDataSource LOCAL oDataSet IF Empty( cName ) RETURN Nil ENDIF UPDATE ::cProcess TO cProcess IF ! ::lConnected ::Connect() ENDIF oDataSet := TDataSet():Create( ::oParent, Self, cName, Upper( ::cProcess ) ) RETURN oDataSet //-------------------------------------------------------------------------- METHOD AddDataSet( oDataSet ) CLASS XDataSource AAdd( ::aDataSet, oDataSet ) RETURN Nil //-------------------------------------------------------------------------- METHOD DelDataSet( oDataSet, lFree ) CLASS XDataSource LOCAL nAT DEFAULT lFree TO .T. nAt := Ascan( ::aDataSet, { |v| v == oDataSet } ) IF nAt > 0 IF lFree oDataSet:End() ELSE ADel( ::aDataSet, nAt ) ASize( ::aDataSet, Len( ::aDataSet ) - 1 ) ENDIF ENDIF RETURN ( nAT > 0 ) //-------------------------------------------------------------------------- METHOD OpenProcess( cProcess ) CLASS XDataSource LOCAL nFor DEFAULT cProcess TO ::cProcess cProcess := Upper( cProcess ) FOR nFor := 1 TO Len( ::aDataSet ) WITH OBJECT ::aDataSet[ nFor ] IF :cProcess == cProcess IF ! :Open() RETURN .F. ENDIF ENDIF END OBJECT NEXT RETURN .T. //-------------------------------------------------------------------------- METHOD CloseProcess( cProcess ) CLASS XDataSource DEFAULT cProcess TO ::cProcess cProcess := Upper( cProcess ) AEval( ::aDataSet, {|v| IIf( v:cProcess == cProcess, v:Close(), ) } ) RETURN Nil //-------------------------------------------------------------------------- METHOD DelProcess( cProcess ) CLASS XDataSource LOCAL nAt LOCAL nClosed DEFAULT cProcess TO ::cProcess cProcess := Upper( cProcess ) nClosed := 0 DO WHILE ( nAt := AScan( ::aDataSet, { |v| v:cProcess == cProcess } ) ) > 0 ::DelDataSet( ::aDataSet[ nAt ] ) nClosed ++ ENDDO RETURN nClosed //-------------------------------------------------------------------------- METHOD GetDataSet( cName, cProcess ) CLASS XDataSource LOCAL nFor IF cProcess != Nil cProcess := Upper( cProcess ) ENDIF cName := Upper( cName ) FOR nFor := 1 TO Len( ::aDataSet ) WITH OBJECT ::aDataSet[ nFor ] IF ( cProcess = Nil .OR. :cProcess == cProcess ) .AND. cName == Upper( :cName ) RETURN ::aDataSet[ nFor ] ENDIF END OBJECT NEXT RETURN Nil //-------------------------------------------------------------------------- METHOD BuildSQLSt( ... ) CLASS XDataSource LOCAL aParams LOCAL cSql LOCAL nFor, nLen, nDec, nLeft, nRight LOCAL xPar, nAt, nPos := 1, cValue aParams := hb_Aparams() nLen := Len( aParams ) IF nLen == 0 RETURN "" ENDIF cSql := TrimSelect( StrDecodeEscape( aParams[ 1 ] ) ) Adel( aParams, 1 ) Asize( aParams, nLen - 1 ) IF nLen > 1 .AND. Valtype( aParams[ 1 ] ) == "A" aParams := aParams[ 1 ] ENDIF nLen := Len( aParams ) FOR nFor := 1 TO nLen xPar := aParams[ nFor ] nLeft := 0 nRight := 0 IF ( nAt := hb_At( "?", cSql, nPos ) ) == 0 EXIT ENDIF SWITCH Valtype( xPar ) CASE "D" cValue := "'" + ::DToSql( xPar ) + "'" EXIT CASE "T" cValue := "'" + ::GetDateSql( xPar ) + "'" EXIT CASE "L" cValue := IIF( xPar, "1", "0" ) EXIT CASE "N" cValue := Alltrim( Str( xPar ) ) EXIT CASE "C" CASE "M" IF Substr( cSql, nAt - 1, 1 ) == "%" cValue := "'%" + ::StrSql( xPar ) + "'" nLeft := 1 ELSEIF Substr( cSql, nAt + 1, 1 ) == "%" cValue := "'" + ::StrSql( xPar ) + "%'" nRight := 1 ELSE cValue := "'" + ::StrSql( xPar ) + "'" ENDIF EXIT OTHERWISE cValue := "NULL" END SWITCH cSql := Left( cSql, nAt - 1 - nLeft ) + cValue + Substr( cSql, nAt + 1 + nRight ) nPos := nAt + Len( cValue ) NEXT //logdebug( cSql ) RETURN cSql //-------------------------------------------------------------------------- METHOD SqlInsert( oRecord, cTable, lOnlyMod ) CLASS XDataSource LOCAL xVal LOCAL cSql, cVal LOCAL nFor, nLen DEFAULT lOnlyMod TO .F. cSql := "INSERT INTO " + cTable + " (" nLen = oRecord:Len() FOR nFor := 1 TO nLen IF !lOnlyMod .OR. oRecord:Modified( nFor ) cSql += "[" + oRecord:GetName( nFor ) + "]," ENDIF NEXT SwapChr( @cSql, Len( cSql ), ")" ) cSql += " VALUES (" FOR nFor := 1 TO nLen IF !lOnlyMod .OR. oRecord:Modified( nFor ) xVal := oRecord:GetValue( nFor ) SWITCH ValType( xVal ) CASE "D" cVal := "'" + ::DToSql( xVal ) + "'" EXIT CASE "T" cVal := "'" + ::GetDateSql( xVal ) + "'" EXIT CASE "L" cVal := IIF( xVal, "1", "0" ) EXIT CASE "N" cVal := Alltrim( Str( xVal ) ) EXIT CASE "C" cVal := "'" + ::StrSql( xVal ) + "'" EXIT OTHERWISE cVal := "NULL" END SWITCH cSql += cVal + "," ENDIF NEXT IF !( "," $ cSql ) RETURN "" ENDIF SwapChr( @cSql, Len( cSql ), ")" ) RETURN cSql //-------------------------------------------------------------------------- METHOD SqlUpdate( oRecord, cTable, lOnlyMod ) CLASS XDataSource LOCAL xVal LOCAL cSql, cVal LOCAL nFor, nLen DEFAULT lOnlyMod TO .F. cSql := "UPDATE " + cTable + " SET " nLen = oRecord:Len() FOR nFor := 1 TO nLen IF !lOnlyMod .OR. oRecord:Modified( nFor ) cSql += "[" + oRecord:GetName( nFor ) + "]=" xVal := oRecord:GetValue( nFor ) SWITCH ValType( xVal ) CASE "D" cVal := "'" + ::DToSql( xVal ) + "'" EXIT CASE "T" cVal := "'" + ::GetDateSql( xVal ) + "'" EXIT CASE "L" cVal := IIF( xVal, "1", "0" ) EXIT CASE "N" cVal := Alltrim( Str( xVal ) ) EXIT CASE "C" cVal := "'" + ::StrSql( xVal ) + "'" EXIT OTHERWISE cVal := "NULL" END SWITCH cSql += cVal + "," ENDIF NEXT IF !( "," $ cSql ) RETURN "" ENDIF SwapChr( @cSql, Len( cSql ), " " ) cSql += "WHERE " // You must complete the sentence ... RETURN cSql //-------------------------------------------------------------------------- METHOD QueryMemDataset( cCommand, cProcess, oMemRS ) CLASS XDataSource LOCAL oRS LOCAL aRows LOCAL lOwnRs lOwnRs := Empty( oMemRS ) WITH OBJECT oRS := ::Query( cCommand, cProcess ) :nCursorLocation := adUseClient :nLockType := adLockReadOnly :lReadOnly := .T. IF :Open() aRows := :GetRows() IF lOwnRs oMemRS := TMemDataSet():Create() ENDIF WITH OBJECT oMemRS :cCommand := cCommand :lIsTable := oRS:oRecords:lIsTable :GetStructFrom( oRS ) :Open( aRows ) END WITH ENDIF :End() END WITH RETURN oMemRS //-------------------------------------------------------------------------- METHOD SetConnect( cConnect ) CLASS XDataSource LOCAL cName LOCAL nFor ::FcConnect := cConnect FOR nFor := 1 TO Len( ::aDataSet ) cName := ::aDataSet[ nFor ]:cName IF !( "\" $ cName ) ::aDataSet[ nFor ]:cName := cName ENDIF NEXT RETURN Nil //-------------------------------------------------------------------------- METHOD RunProcDirect( cProcName, aParams ) CLASS XDataSource LOCAL oProc AS CLASS TSQLProc LOCAL xValue LOCAL nFor IF ValType( aParams ) != "A" aParams := { aParams } ENDIF WITH OBJECT oProc := TSQLProc():Create() :cName := cProcName :oDataSource := Self FOR nFor := 1 TO Len( aParams ) :AddParam( "v_" + LTrim( Str( nFor ) ), adParamInput,,, aParams[ nFor ] ) NEXT IF :Run() xValue := :ReturnValue() ENDIF :End() END WITH RETURN xValue //-------------------------------------------------------------------------- METHOD NewError( cError, nError, oDataSet, cName, lMasive ) CLASS XDataSource LOCAL oError LOCAL cSet, cMsg, cProc LOCAL nProc LOCAL lRet DEFAULT lMasive TO .F. DEFAULT nError TO 0 IF cName == Nil .AND. oDataSet != Nil cName := oDataSet:cName ENDIF IF oDataSet != Nil oDataSet:cLastError := cError oDataSet:nLastError := nError ENDIF nProc := 0 DO WHILE "DATA"$ProcName( nProc ) .OR. "RECORDS"$ProcName( nProc ) .OR. "TSQL"$ProcName( nProc ) nProc++ ENDDO cSet := IIf( cName != Nil, cName, "[" + LT( XA_MSG_NINGUNO ) + "]" ) cProc := LT( XA_MSG_EN_PROCEDIMIENTO ) + ": " + ProcName( nProc ) + " " + LT( XA_MSG_LINEA ) + ": " + LTrim( Str( ProcLine( nProc ) ) ) IF Empty( nError ) nError := IIf( oDataSet != Nil, oDataSet:nLastError, 0 ) ENDIF AAdd( ::aErrors, { cSet, cError, nError, cProc } ) cMsg := cSet + CRLF + Space( 5 ) + cError + " [# " + LTrim( Str( nError ) ) + "]" + ; CRLF + Space( 5 ) + cProc IF ! lMasive IF ::lDisplayErrors .OR. oDataSet != Nil .AND. oDataSet:lDisplayErrors MsgAlert( cMsg, "Xailer: DataControls error") ELSEIF IsDebuggerPresent() .AND. IsDebug() LogDebug( cMsg ) ENDIF IF ::lAbortOnErrors oError := ErrorNew() oError:Subsystem := "XAILER" IF ! Empty( nError ) oError:SubCode := nError ENDIF oError:Severity := ES_ERROR oError:Description := cError oError:Operation := cSet lRet := ::OnError( oError ) IF lRet == NIL .OR. lRet != .F. Eval( ErrorBlock(), oError, oDataSet ) ENDIF ENDIF ENDIF RETURN Nil //-------------------------------------------------------------------------- METHOD ShowMasiveError( oDataSet ) CLASS XDataSource LOCAL oError LOCAL aError LOCAL cError, cSet, cMsg LOCAL nError LOCAL lRet cMsg := "" FOR EACH aError IN ::aErrors cSet := aError[ 1 ] cError := aError[ 2 ] nError := aError[ 3 ] cMsg += cSet + CRLF + CRLF +; cError + " [# " + LTrim( Str( nError ) ) + "]" + CRLF + CRLF + ; aError[ 4 ] IF aError:__EnumIndex() < Len( ::aErrors) cMsg += CRLF + CRLF ENDIF NEXT IF ::lDisplayErrors .OR. oDataSet != Nil .AND. oDataSet:lDisplayErrors MsgAlert( cMsg, "Xailer: DataControls error") ELSE LogDebug( cMsg ) ENDIF IF ::lAbortOnErrors oError := ErrorNew() oError:Subsystem := "XAILER" IF ! Empty( nError ) oError:SubCode := nError ENDIF oError:Severity := ES_ERROR oError:Description := cError oError:Operation := cSet lRet := ::OnError( oError ) IF lRet == NIL .OR. lRet != .F. Eval( ErrorBlock(), oError, oDataset ) ENDIF ENDIF RETURN cMsg //-------------------------------------------------------------------------- METHOD ShowErrorList( cTitle ) CLASS XDataSource LOCAL oFrm, oBrw DEFAULT cTitle TO LT( XA_MSG_ERRORES_DE_TDATASOURCE ) + ": " + ::cConnect IF Len( ::aErrors ) == 0 MsgInfo( "TDataSource: " + LT( XA_MSG_NINGUN_ERROR ), cTitle ) RETURN Nil ENDIF WITH OBJECT oFrm := TForm():New( Application:oMainForm ) :SetBounds( 0, 0, 600, 440) :cText := cTitle :lCentered := .T. :Create() END WITH WITH OBJECT oBrw := TArrayBrowse():New( oFrm ) :nAlign := alCLIENT :nMarqueeStyle := bmHIGHLROW :nRowDividerStyle := blLIGHTGRAY :nColDividerStyle := blLIGHTGRAY :nDataLines := 4 :Create() :SetArray( ::aErrors, { "TDataSet", "Descrip.", "# Error", "Trace" }, .T. ) END WITH oFrm:ShowModal() RETURN Nil //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- RESERVED PROCEDURE DataSourceExitProc() LOCAL n, nOpen FOR n := Len( aDataSources ) TO 1 STEP -1 WITH OBJECT aDataSources[ n ] nOpen := 0 Aeval( :aDataset, {|v| iif( v:lOpen, nOpen ++ , ) } ) IF nOpen > 0 .and. IsDebug() MsgAlert( "XAILER " + :Classname() + ": " + ; Ltrim( Str( nOpen ) ) + " files not closed correctly" ) ENDIF :End() END WITH NEXT RETURN //-------------------------------------------------------------------------- PROCEDURE DataSourceCloseAll() // --> n/a LOCAL n FOR n := Len( aDataSources ) TO 1 STEP -1 aDataSources[ n ]:End() NEXT RETURN //-------------------------------------------------------------------------- FUNCTION MySqlDateFormat() LOCAL cFormat SWITCH Set( _SET_DATEFORMAT ) CASE "mm/dd/yy" cFormat := "'%m/%d/%Y'" EXIT CASE "yy.mm.dd" cFormat := "'%Y.%m.%d'" EXIT CASE "dd/mm/yy" cFormat := "'%d/%m/%Y'" EXIT CASE "dd.mm.yy" cFormat := "'%d.%m.%Y'" EXIT CASE "dd-mm-yy" cFormat := "'%d-%m-%Y'" EXIT CASE "yy/mm/dd" cFormat := "'%Y/%m/%d'" EXIT CASE "mm-dd-yy" cFormat := "'%m-%d-%Y'" EXIT OTHERWISE cFormat := "'%d-%m-%Y'" END SWITCH RETURN cFormat //-------------------------------------------------------------------------- STATIC FUNCTION Decs( nValue ) LOCAL nDecs := 0 LOCAL n := 1 DO WHILE ( nValue * n ) != Int( nValue * n ) n *= 10 nDecs ++ ENDDO RETURN nDecs //-------------------------------------------------------------------------- STATIC FUNCTION GetDateSQL( dDate ) LOCAL cDt IF Empty( dDate ) RETURN "NULL" ENDIF cDt := HB_Ttos( dDate ) RETURN Left( cDt, 4 ) + "-" + Substr( cDt, 5, 2 ) + "-" + ; Substr( cDt, 7, 2 ) + " " + Substr( cDt, 9, 2 ) + ":" +; Substr( cDt, 11, 2 )+ ":" + Substr( cDt, 13, 2 ) //-------------------------------------------------------------------------- STATIC FUNCTION TrimSelect( cSelect ) LOCAL cRet, cChar, cLast LOCAL lInString cRet := "" cLast := " " lInString := .F. cSelect := StrTran( cSelect, CRLF, " " ) FOR EACH cChar IN cSelect SWITCH cChar CASE " " IF cLast != " " .OR. lInString cRet += cChar ENDIF EXIT CASE "'" CASE '"' lInString := !lInString cRet += cChar EXIT OTHERWISE cRet += cChar END SWITCH cLast := cChar NEXT RETURN cRet //------------------------------------------------------------------------------ #pragma BEGINDUMP #include "xailer.h" char * StrSql( const char * cString, const char * cChars ); HB_FUNC_STATIC( XDATASOURCE_STRSQL ) { LPSTR cRet = StrSql( hb_parc( 1 ), "'\\" ); // Por defecto MySQL hb_retc_buffer( cRet ); } //------------------------------------------------------------------------------ XA_FUNC( CHECKSQLINJECTION ) // CheckSQLInjection( ) --> lResult { const char *cSql = hb_parc( 1 ); char c; int lString = FALSE; int lInjection = FALSE; while( ( c = *cSql++ ) != 0 ) { if( c == '\'' ) lString = !lString; else if( ( c == ';' ) && ( !lString ) ) { lInjection = TRUE; break; } } hb_retl( lInjection ); } //-------------------------------------------------------------------------- #pragma ENDDUMP