9687850865
* (all files)
* stripped svn header
* minor cleanups
; use following command to find out the history of files:
git log
git log --follow
git blame
git annotate
506 lines
11 KiB
Plaintext
506 lines
11 KiB
Plaintext
/*
|
|
* xHarbour Project source code:
|
|
* CStr( xAnyType ) -> String
|
|
*
|
|
* Copyright 2001 Ron Pinkas <ron@@ronpinkas.com>
|
|
* www - http://www.xharbour.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.txt. 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, xHarbour license gives permission for
|
|
* additional uses of the text contained in its release of xHarbour.
|
|
*
|
|
* The exception is that, if you link the xHarbour 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 xHarbour 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 with this xHarbour
|
|
* explicit exception. If you add/copy code from other sources,
|
|
* as the General Public License permits, the above 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 xHarbour, 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 "error.ch"
|
|
|
|
#include "hbclass.ch"
|
|
|
|
/*
|
|
For performance NOT using OS indpendant R/T function,
|
|
this define only used in ValTpPrg() which currently only used in win32.
|
|
*/
|
|
|
|
#define CRLF Chr( 13 ) + Chr( 10 )
|
|
|
|
#xtranslate Throw( <oErr> ) => ( Eval( ErrorBlock(), <oErr> ), Break( <oErr> ) )
|
|
|
|
//
|
|
|
|
FUNCTION CStrToVal( cExp, cType )
|
|
|
|
IF ! HB_ISSTRING( cExp )
|
|
Throw( xhb_ErrorNew( "CSTR", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
|
|
ENDIF
|
|
|
|
SWITCH cType
|
|
CASE "C"
|
|
RETURN cExp
|
|
|
|
CASE "P"
|
|
RETURN hb_HexToNum( cExp )
|
|
|
|
CASE "D"
|
|
IF cExp[ 3 ] >= "0" .AND. cExp[ 3 ] <= "9" .AND. cExp[ 5 ] >= "0" .AND. cExp[ 5 ] <= "9"
|
|
RETURN hb_SToD( cExp )
|
|
ELSE
|
|
RETURN CToD( cExp )
|
|
ENDIF
|
|
|
|
CASE "L"
|
|
RETURN iif( cExp[ 1 ] == "T" .OR. cExp[ 1 ] == "Y" .OR. cExp[ 2 ] == "T" .OR. cExp[ 2 ] == "Y", .T., .F. )
|
|
|
|
CASE "N"
|
|
RETURN Val( cExp )
|
|
|
|
CASE "U"
|
|
RETURN NIL
|
|
|
|
/*
|
|
CASE "A"
|
|
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
|
|
|
|
CASE "B"
|
|
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
|
|
|
|
CASE "O"
|
|
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
|
|
*/
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN NIL
|
|
|
|
//
|
|
|
|
FUNCTION StringToLiteral( cString )
|
|
|
|
LOCAL lDouble := .F.
|
|
LOCAL lSingle := .F.
|
|
|
|
IF hb_regexHas( "\n|\r", cString ) .OR. ;
|
|
( ( lDouble := '"' $ cString ) .AND. ;
|
|
( lSingle := "'" $ cString ) .AND. ;
|
|
hb_regexHas( "\[|\]", cString ) )
|
|
|
|
cString := StrTran( cString, '"', '\"' )
|
|
cString := StrTran( cString, Chr( 10 ), "\n" )
|
|
cString := StrTran( cString, Chr( 13 ), "\r" )
|
|
|
|
// TraceLog( cString )
|
|
|
|
RETURN 'E"' + cString + '"'
|
|
ELSEIF ! lDouble
|
|
RETURN '"' + cString + '"'
|
|
ELSEIF ! lSingle
|
|
RETURN "'" + cString + "'"
|
|
ENDIF
|
|
|
|
RETURN "[" + cString + "]"
|
|
|
|
//
|
|
|
|
FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
|
|
|
|
LOCAL aVar, cRet, cPad, nObj
|
|
|
|
// TraceLog( xVal, cName, nPad, aObjs )
|
|
|
|
SWITCH ValType( xVal )
|
|
CASE "C"
|
|
RETURN StringToLiteral( xVal )
|
|
|
|
CASE "D"
|
|
RETURN "hb_SToD( '" + DToS( xVal ) + "' )"
|
|
|
|
CASE "L"
|
|
RETURN iif( xVal, ".T.", ".F." )
|
|
|
|
CASE "N"
|
|
RETURN hb_ntos( xVal )
|
|
|
|
CASE "A"
|
|
IF cName == NIL
|
|
nPad := 0
|
|
cName := "M->__ValToPrg_Array"
|
|
aObjs := {}
|
|
cRet := cName + " := "
|
|
ELSE
|
|
IF ( nObj := AScan( aObjs, {| a | hb_ArrayId( a[ 1 ] ) == hb_ArrayId( xVal ) } ) ) > 0
|
|
RETURN aObjs[ nObj ][ 2 ] + " /* Cyclic */"
|
|
ENDIF
|
|
|
|
cRet := ""
|
|
ENDIF
|
|
|
|
AAdd( aObjs, { xVal, cName } )
|
|
|
|
cRet += "Array(" + hb_ntos( Len( xVal ) ) + ")" + CRLF
|
|
|
|
nPad += 3
|
|
cPad := Space( nPad )
|
|
|
|
FOR EACH aVar IN xVal
|
|
cRet += cPad + cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "] := " + ValToPrg( aVar, cName + "[" + hb_ntos( aVar:__EnumIndex() ) + "]", nPad, aObjs ) + CRLF
|
|
NEXT
|
|
|
|
nPad -= 3
|
|
|
|
RETURN cRet
|
|
|
|
CASE "H"
|
|
IF Empty( xVal )
|
|
cRet := "hb_Hash()"
|
|
ELSE
|
|
cRet := "{ "
|
|
FOR EACH aVar IN xVal
|
|
IF aVar:__enumIndex() != 1
|
|
cRet += ", "
|
|
ENDIF
|
|
cRet += ValToPrg( aVar:__enumKey() )
|
|
cRet += " => "
|
|
cRet += ValToPrg( aVar )
|
|
NEXT
|
|
cRet += " }"
|
|
ENDIF
|
|
|
|
RETURN cRet
|
|
|
|
/* There is no support for codeblock serialization */
|
|
#if 0
|
|
CASE "B"
|
|
RETURN ValToPrgExp( xVal )
|
|
#endif
|
|
|
|
CASE "P"
|
|
RETURN "0x" + hb_NumToHex( xVal )
|
|
|
|
CASE "O"
|
|
/* TODO: Use HBPersistent() when avialable! */
|
|
IF cName == NIL
|
|
cName := "M->__ValToPrg_Object"
|
|
nPad := 0
|
|
aObjs := {}
|
|
cRet := cName + " := "
|
|
ELSE
|
|
IF ( nObj := AScan( aObjs, {| a | hb_ArrayId( a[ 1 ] ) == hb_ArrayId( xVal ) } ) ) > 0
|
|
RETURN aObjs[ nObj ][ 2 ] + " /* Cyclic */"
|
|
ENDIF
|
|
|
|
cRet := ""
|
|
ENDIF
|
|
|
|
AAdd( aObjs, { xVal, cName } )
|
|
|
|
cRet += xVal:ClassName + "():New()" + CRLF
|
|
|
|
nPad += 3
|
|
cPad := Space( nPad )
|
|
|
|
FOR EACH aVar IN __objGetValueList( xVal )
|
|
cRet += cPad + cName + ":" + aVar[ 1 ] + " := " + ValToPrg( aVar[ 2 ], cName + ":" + aVar[ 1 ], nPad, aObjs ) + CRLF
|
|
NEXT
|
|
|
|
nPad -= 3
|
|
RETURN cRet
|
|
|
|
OTHERWISE
|
|
// TraceLog( xVal, cName, nPad )
|
|
IF xVal == NIL
|
|
cRet := "NIL"
|
|
ELSE
|
|
Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDIF
|
|
ENDSWITCH
|
|
|
|
// TraceLog( cRet )
|
|
|
|
RETURN cRet
|
|
|
|
//
|
|
|
|
FUNCTION PrgExpToVal( cExp )
|
|
|
|
RETURN Eval( hb_macroBlock( cExp ) )
|
|
|
|
//
|
|
|
|
FUNCTION ValToArray( xVal )
|
|
|
|
IF HB_ISARRAY( xVal )
|
|
RETURN xVal
|
|
ENDIF
|
|
|
|
RETURN { xVal }
|
|
|
|
//
|
|
|
|
FUNCTION ValToBlock( xVal )
|
|
|
|
IF HB_ISBLOCK( xVal )
|
|
RETURN xVal
|
|
ENDIF
|
|
|
|
RETURN {|| xVal }
|
|
|
|
//
|
|
|
|
FUNCTION ValToCharacter( xVal )
|
|
|
|
IF HB_ISSTRING( xVal )
|
|
RETURN xVal
|
|
ENDIF
|
|
|
|
RETURN LTrim( CStr( xVal ) )
|
|
|
|
//
|
|
|
|
FUNCTION ValToDate( xVal )
|
|
|
|
SWITCH ValType( xVal )
|
|
CASE "A"
|
|
CASE "H"
|
|
CASE "L"
|
|
CASE "O"
|
|
CASE "U"
|
|
EXIT
|
|
|
|
CASE "B"
|
|
RETURN ValToDate( Eval( xVal ) )
|
|
|
|
CASE "C"
|
|
IF SubStr( DToS( xVal ), 3, 1 ) >= "0" .AND. ;
|
|
SubStr( DToS( xVal ), 3, 1 ) <= "9" .AND. ;
|
|
SubStr( DToS( xVal ), 5, 1 ) >= "0" .AND. ;
|
|
SubStr( DToS( xVal ), 5, 1 ) <= "9"
|
|
RETURN hb_SToD( xVal )
|
|
ELSE
|
|
RETURN CToD( xVal )
|
|
ENDIF
|
|
|
|
CASE "D"
|
|
RETURN xVal
|
|
|
|
CASE "N"
|
|
CASE "P"
|
|
RETURN 0d19000101 + xVal
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN hb_SToD()
|
|
|
|
//
|
|
|
|
FUNCTION ValToHash( xVal )
|
|
|
|
IF HB_ISHASH( xVal )
|
|
RETURN xVal
|
|
ENDIF
|
|
|
|
RETURN { ValToCharacter( xVal ) => xVal }
|
|
|
|
//
|
|
|
|
FUNCTION ValToLogical( xVal )
|
|
|
|
SWITCH ValType( xVal )
|
|
CASE "A"
|
|
CASE "D"
|
|
CASE "H"
|
|
CASE "N"
|
|
CASE "O"
|
|
CASE "P"
|
|
RETURN ! Empty( xVal )
|
|
|
|
CASE "B"
|
|
RETURN ValToLogical( Eval( xVal ) )
|
|
|
|
CASE "C"
|
|
IF Left( xVal, 1 ) == "." .AND. SubStr( xVal, 3, 1 ) == "." .AND. Upper( SubStr( xVal, 2, 1 ) ) $ "TFYN"
|
|
RETURN Upper( SubStr( xVal, 2, 1 ) ) $ "TY"
|
|
ELSEIF Len( xVal ) == 1 .AND. Upper( xVal ) $ "TFYN"
|
|
RETURN Upper( xVal ) $ "TY"
|
|
ELSE
|
|
RETURN ! Empty( xVal )
|
|
ENDIF
|
|
EXIT
|
|
|
|
CASE "L"
|
|
RETURN xVal
|
|
|
|
CASE "U"
|
|
RETURN .F.
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN .F.
|
|
|
|
//
|
|
|
|
FUNCTION ValToNumber( xVal )
|
|
|
|
SWITCH ValType( xVal )
|
|
CASE "A"
|
|
CASE "H"
|
|
RETURN Len( xVal )
|
|
|
|
CASE "B"
|
|
RETURN ValToNumber( Eval( xVal ) )
|
|
|
|
CASE "C"
|
|
RETURN Val( xVal )
|
|
|
|
CASE "D"
|
|
RETURN xVal - 0d19000101
|
|
|
|
CASE "L"
|
|
RETURN iif( xVal, 1, 0 )
|
|
|
|
CASE "O"
|
|
RETURN xVal:hClass
|
|
|
|
CASE "N"
|
|
RETURN xVal
|
|
|
|
CASE "P"
|
|
RETURN xVal - 0
|
|
|
|
CASE "U"
|
|
RETURN 0
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN 0
|
|
|
|
//
|
|
|
|
FUNCTION ValToObject( xVal )
|
|
|
|
SWITCH ValType( xVal )
|
|
CASE "A"
|
|
ENABLE TYPE CLASS ARRAY
|
|
EXIT
|
|
|
|
CASE "B"
|
|
ENABLE TYPE CLASS BLOCK
|
|
EXIT
|
|
|
|
CASE "C"
|
|
ENABLE TYPE CLASS CHARACTER
|
|
EXIT
|
|
|
|
CASE "D"
|
|
ENABLE TYPE CLASS DATE
|
|
EXIT
|
|
|
|
CASE "H"
|
|
ENABLE TYPE CLASS HASH
|
|
EXIT
|
|
|
|
CASE "L"
|
|
ENABLE TYPE CLASS LOGICAL
|
|
EXIT
|
|
|
|
CASE "N"
|
|
ENABLE TYPE CLASS NUMERIC
|
|
EXIT
|
|
|
|
CASE "O"
|
|
RETURN xVal
|
|
|
|
CASE "P"
|
|
ENABLE TYPE CLASS POINTER
|
|
EXIT
|
|
|
|
CASE "U"
|
|
ENABLE TYPE CLASS NIL
|
|
EXIT
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN 0
|
|
|
|
//
|
|
|
|
FUNCTION ValToType( xVal, cType )
|
|
|
|
SWITCH cType
|
|
CASE "A"
|
|
RETURN ValToArray( xVal )
|
|
|
|
CASE "B"
|
|
RETURN ValToBlock( xVal )
|
|
|
|
CASE "C"
|
|
RETURN ValToCharacter( xVal )
|
|
|
|
CASE "D"
|
|
RETURN ValToDate( xVal )
|
|
|
|
CASE "H"
|
|
RETURN ValToHash( xVal )
|
|
|
|
CASE "L"
|
|
RETURN ValToLogical( xVal )
|
|
|
|
CASE "N"
|
|
RETURN ValToNumber( xVal )
|
|
|
|
CASE "O"
|
|
RETURN ValToObject( xVal )
|
|
|
|
CASE "P"
|
|
RETURN ValToNumber( xVal )
|
|
|
|
CASE "U"
|
|
RETURN NIL
|
|
|
|
OTHERWISE
|
|
Throw( xhb_ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
|
|
ENDSWITCH
|
|
|
|
RETURN NIL
|