*-------------------------------------------------------------------------------------------
* Created by Marco Plaza @nfoxdev
* v. 1.100 - 2016/02/24
* enabled collection processing
* v. 1.101 - 2016/02/24
* solved indentation on nested collections
* ver 1.110 -2016/03/11
* -added support for collections inside arrays
* -user can pass aMemembersFlag value
*  ( since Json is intended for DTO creation default value is 'U' )
*   check amembers topic on vfp help file for usage
* changed cr to crlf
* Added Json validation ; throws error for invalid Json.

* v. 1.120 encode control characters ( chr(0) ~ chr(31) )
* v. 1.121 - 2023/07/26 - minor optimization ( escapeandencode() )
* v. 1.122 - 2024/06//18 - workaround for a minor issue with a bug in vfp9 09.00.0000.2412
* v. 1.123 - 2024/08/14 - escapeandencode - bug mapping chars asc 21 to asc 31 as decimal, corrected as hex. ( thks2 @mPeirse )
*-------------------------------------------------------------------------------------------
*** DH 2026-02-12:	Accept an array of properties. The first column is the property name,
***					the case of which is used in the JSON, the second is a comma-delimited
***					list of the names of the members this applies to , the third is .T. to
***					exclude the property or .F. to include it, and the fourth is how to handle
***					the property if its value is empty: 0 = include it as is in the JSON,
***					1 = use null as the value, 2 = omit the property from the JSON.
***					Also, accept a flag indicating that collections are not assign new names
***					using collTagName
*parameters ovfp,formattedOutput,nonullarrayitem,crootName,aMembersFlag
parameters ovfp,formattedOutput,nonullarrayitem,crootName,aMembersFlag, tlNoCollectionName, taProperties
*** DH 2026-02-18: added EXTERNAL ARRAY to avoid Project Manager errors
external array taProperties

#define crlf chr(13)+Chr(10)

private all
amembersFlag = evl(m.amembersFlag,'U')

esarray = type('oVfp',1) = 'A'
esobjeto = vartype(m.ovfp) = 'O'

if !m.esarray and !m.esobjeto
	Error 'must supply a vfp object/array'
	return
endif

_nivel = iif( cast(m.formattedOutput as l ) , 1, -1)

lcPoint = set('Point')
SET POINT TO '.'

do case
case esarray

	ojson = createobject('empty')

	addproperty(ojson,'array(1)')
	acopy(ovfp,ojson.array)
*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*	cjson = procobject(ojson,.f.,m.nonullarrayitem,m.amembersFlag)
	cjson = procobject(ojson,.f.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)
	cJson = substr( m.cJson,at('[',m.cJson))

case type('oVfp.BaseClass')='C' and ovfp.baseclass = 'Collection'
*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*	cjson = procobject(ovfp,.t.,m.nonullarrayitem,m.amembersFlag)
	cjson = procobject(ovfp,.t.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)

	cRootName    = evl(m.cRootName,'collection')
	cjson = '{"'+m.cRootName+collTagName(oVfp)+'": '+cjson+'}'+IIF(formattedoutput,crlf,'')+'}'

otherwise
*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*	cjson = '{'+procobject(ovfp,.f.,m.nonullarrayitem,m.amembersFlag)+'}'
	cjson = '{'+procobject(ovfp,.f.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)+'}'

endcase

SET POINT TO (m.lcPoint)

return ltrim(m.cjson)

*----------------------------------------
function collTagName(thiscoll)
*----------------------------------------
return iif( m.thiscoll.Count > 0 And !Empty( m.thiscoll.GetKey(1) ), '_kv_collection','_kl_collection' )

*----------------------------------------------------------------------------------
*** DH 2026-02-12: accept taProperties and tlNoCollectionName
*function procobject(obt,iscollection,nonullarrayitem,amembersFlag)
function procobject(obt,iscollection,nonullarrayitem,amembersFlag, taProperties, tlNoCollectionName)
*----------------------------------------------------------------------------------

if isnull(m.obt)
	return 'null'
endif

private all except _nivel

este = ''

xtabs = nivel(2)

bc = iif(type('m.obt.baseclass')='C',m.obt.baseclass,'?')

iscollection =  bc = 'Collection'

if m.iscollection

*** DH 2026-02-12: don't add { and "collectionitems" if tlNoCollectionName is .T.
*	este = m.este+'{ '+m.xtabs
*	xtabs = nivel(2)
*	este = m.este+'"collectionitems": ['+m.xtabs
	if tlNoCollectionName
		xtabs = nivel(2)
		este = m.este + '[' + m.xtabs
	else
		este = m.este+'{ '+m.xtabs
		xtabs = nivel(2)
		este = m.este+'"collectionitems": ['+m.xtabs
	endif tlNoCollectionName
*** DH 2026-02-12: end of change

*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*	procCollection(obt,m.noNullArrayItem,m.amembersFlag)
	procCollection(obt,m.noNullArrayItem,m.amembersFlag, @taProperties, tlNoCollectionName)

	xtabs = nivel(-2)
	este  = m.este+m.xtabs+']'

else

	amembers(am,m.obt,0,m.amembersFlag)

	if vartype(m.am) = 'U'
		xtabs=m.nivel(-2)
		return ''
	endif

	nm = alen(am)

*** DH 2026-20-12:	add members specified in taProperties that we aren't excluding and
***					belong to this class
	llHaveProperties = type('taProperties', 1) = 'A'
	if llHaveProperties
		for x1 = 1 to alen(taProperties, 1)
			if not taProperties[x1, 3] and ;
				ascan(m.am, taProperties[x1, 1], -1, -1, 1, 15) = 0 and ;
				pemstatus(m.obt, taProperties[x1, 1], 5) and ;
				(empty(taProperties[x1, 2]) or ;
					',' + upper(obt.Name) + ',' $ ',' + upper(taProperties[x1, 2]) + ',')
				nm = nm + 1
				dimension am[nm]
				am[nm] = taProperties[x1, 1]
			endif not taProperties[x1, 3] ...
		next x1
	endif llHaveProperties
*** DH 2026-20-12: end of new code

	for x1 = 1 to m.nm

		var = lower(am(m.x1))

*** DH 2026-02-12:	find the property name in taProperties, omit it if we're excluding it,
***					use the specified case, and determine how to handle it.
		lnHowToHandle = 0
		if llHaveProperties
			lnRow = ascan(taProperties, var, -1, -1, 1, 15)
			do case
				case lnRow = 0
				case taProperties[lnRow, 3]
					loop
				otherwise
					var = taProperties[lnRow, 1]
					lnHowToHandle = evl(taProperties[lnRow, 4], 0)
			endcase
		endif llHaveProperties
*** DH 2026-01-02: end of new code

*** DH 2026-02-12: we'll add a comma and the name later if we're not omitting this property
*		este = m.este+iif(m.x1>1,',','')+m.xtabs
*		este = m.este+["]+strtran(m.var,'_vfpsafe_','')+[":]

		esobjeto = type('m.obt.&Var')='O'

		if type('m.obt.&var') = 'U'
			este = m.este+["unable to evaluate expression"]
			loop
		endif

		esarray  = type('m.obt.&Var',1) = 'A'

		do case

		case m.esarray

*** DH 2026-02-12: add comma if necessary and the name
			este = m.este + iif(empty(m.este), '', ',') + m.xtabs
			este = m.este+["]+strtran(m.var,'_vfpsafe_','')+[":]

*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*			procarray(m.obt,m.var,m.nonullarrayitem)
			procarray(m.obt,m.var,m.nonullarrayitem, @taProperties, tlNoCollectionName)

		case m.esobjeto

			thiso=m.obt.&var

			bc = iif(type('m.thiso.baseclass')='C',m.thiso.baseclass,'?')

			if bc = 'Collection'

*** DH 2026-02-12:	handle the value if there are no members: lnHowToHandle = 0
***					means output an empty array, 1 means output null, and 2
***					means omit it from the JSON. Also, output a comma and the name
				do case
					case thiso.Count > 0
					case lnHowToHandle = 1
						thiso = NULL
					case lnHowToHandle = 2
						loop
				endcase
				este = m.este + iif(empty(m.este), '', ',') + m.xtabs
				este = m.este+["]+strtran(m.var,'_vfpsafe_','')+[":]
				if isnull(thiso)
					este = m.este + [null]
					loop
				endif isnull(thiso)
*** DH 2026-02-12: end of new code

*** DH 2026-02-12: don't add new tag name if tlNoCollectionName is .T.
*				este = rtrim(m.este,1,'":')+ collTagName( m.thiso )+'":'
				if tlNoCollectionName
					este = rtrim(m.este,1,'":') + '":'
				else
					este = rtrim(m.este,1,'":')+ collTagName( m.thiso )+'":'
				endif tlNoCollectionName
*** DH 2026-02-12: end of change

*** DH 2026-02-12: pass taProperties and don't add closing } if tlNoCollectionName is .T.
*				este =  m.este+procobject(m.obt.&var,.t.,m.nonullarrayitem,m.amembersFlag)+[}]
				este =  m.este+procobject(m.obt.&var,.t.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName) + ;
					iif(tlNoCollectionName, '', [}])

			else

*** DH 2026-02-12: add comma if necessary and the name
				este = m.este + iif(empty(m.este), '', ',') + m.xtabs
				este = m.este+["]+strtran(m.var,'_vfpsafe_','')+[":]

*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*				este =  m.este+[{]+procobject(m.obt.&var,.f.,m.nonullarrayitem,m.amembersFlag)+[}]
				este =  m.este+[{]+procobject(m.obt.&var,.f.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)+[}]

			endif

		otherwise

*** DH 2026-02-12:	handle the value if there are no members: lnHowToHandle = 0
***					means output an empty value, 1 means output null, and 2
***					means omit it from the JSON. Also, output a comma and the name
*			este = m.este+concatval(m.obt.&var)
			luValue = m.obt.&var
			do case
				case not empty(luValue)
				case lnHowToHandle = 1
					luValue = NULL
				case lnHowToHandle = 2
					loop
			endcase
			este = m.este + iif(empty(m.este), '', ',') + m.xtabs
			este = m.este+["]+strtran(m.var,'_vfpsafe_','')+[":]
			este = m.este+concatval(luValue)
*** DH 2026-02-12: end of new code
		endcase

	endfor

endif

	xtabs = nivel(-2)
	este  = m.este+m.xtabs

return m.este

*----------------------------------------------------
*** DH 2026-02-12: accept taProperties and tlNoCollectionName
*procedure procarray(obt,arrayName,nonullarrayitem)
procedure procarray(obt,arrayName,nonullarrayitem, taProperties, tlNoCollectionName)
*----------------------------------------------------
nrows = alen(m.obt.&arrayName,1)
ncols = alen(m.obt.&arrayName,2)
bidim = m.ncols > 0
ncols = iif(m.ncols=0,m.nrows,m.ncols)
titems = alen(m.obt.&arrayName)

xtabs=nivel(2)

este = m.este+'['+m.xtabs
nelem = 1

do while m.nelem <= m.titems

	este = m.este+iif(m.nelem>1,','+m.xtabs,'')

	if m.bidim
		xtabs = nivel(2)
		este = m.este+'['+m.xtabs
	endif

	for pn = m.nelem to m.nelem+m.ncols-1

		elem = m.obt.&arrayName( m.pn )

		este = m.este+iif(m.pn>m.nelem,','+m.xtabs,'')

		if vartype(m.elem) # 'O'

			if m.nelem+m.ncols-1 = 1 and isnull(m.elem) and m.nonullarrayitem

				este = m.este+""

			else
				este = m.este+concatval(m.elem)

			endif

		else

			bc = iif(type('m.elem.baseclass')='C',m.elem.baseclass,'?')

			if bc = 'Collection'

				este = m.este+' { "collection'+ collTagName( m.elem )+'":'

*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*   				este =  m.este+procobject(m.elem ,.t.,m.nonullarrayitem,m.amembersFlag)
   				este =  m.este+procobject(m.elem ,.t.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)

				este = m.este + '}'+m.xTabs+'}'

			else

*** DH 2026-02-12: pass taProperties and tlNoCollectionName
*   				thisChunk = +[{]+procobject(m.elem ,.f.,m.nonullarrayitem,m.amembersFlag)+[}]
   				thisChunk = [{]+procobject(m.elem ,.f.,m.nonullarrayitem,m.amembersFlag, @taProperties, tlNoCollectionName)+[}]
   				este =  m.este+m.thisChunk

			endif


		endif

	endfor

	nelem = m.pn

	if m.bidim
		xtabs=nivel(-2)
		este = m.este+m.xtabs+']'
	endif

enddo

xtabs=nivel(-2)

este = m.este+m.xtabs+']'

*-----------------------------
function nivel(n)
*-----------------------------
if m._nivel = -1
	return ''
else
	_nivel= m._nivel+m.n
	return crlf+replicate('  ',m._nivel)
endif

*-----------------------------
function concatval(valor)
*-----------------------------

#define specialChars ["\]+chr(127)+CHR(0)+CHR(1)+CHR(2)+CHR(3)+CHR(4)+CHR(5)+CHR(6)+CHR(7)+CHR(8)+CHR(9)+CHR(10)+CHR(11)+CHR(12)+CHR(13)+CHR(14)+CHR(15)+CHR(16)+CHR(17)+CHR(18)+CHR(19)+CHR(20)+CHR(21)+CHR(22)+CHR(23)+CHR(24)+CHR(25)+CHR(26)+CHR(27)+CHR(28)+CHR(29)+CHR(30)+CHR(31)

if isnull(m.valor)

	return 'null'

else

	tvar = vartype(m.valor)
	** no cambiar el orden de ejecución!
	do case
	case m.tvar $ 'FBYINQ'
		vc = rtrim(cast( m.valor as c(32)))
	case m.tvar = 'L'
		vc = iif(m.valor,'true','false')
	case m.tvar $ 'DT'
		vc = ["]+ttoc(m.valor,3)+[Z"]
	case mustEncode(m.valor)
		vc = ["]+escapeandencode(m.valor)+["]
	case m.tvar $ 'CVM'
		vc = ["]+rtrim(m.valor)+["]
	case m.tvar $ 'GQW'
		vc = ["]+strconv(m.valor,13)+["]
	endcase

	return m.vc

endif

*-----------------------------------
FUNCTION mustEncode(valor)
*-----------------------------------
RETURN len(chrtran(m.valor,specialChars,'')) <> len(m.valor)

*-------------------------------
function escapeandencode(valun)
*-------------------------------

valun = strtran(strtran(strtran(strtran(strtran(strtran(strtran(m.valun,;
   '\','\\'),;
   '"','\"'),;
   chr(9),'\t'),;
   chr(10),'\n'),;
   chr(12),'\f'),;
   chr(13),'\r'),;
   chr(127),'\b')

valun = strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(m.valun,;
   chr(0),'\u0000'),;
   chr(1),'\u0001'),;
   chr(2),'\u0002'),;
   chr(3),'\u0003'),;
   chr(4),'\u0004'),;
   chr(5),'\u0005'),;
   chr(6),'\u0006'),;
   chr(7),'\u0007'),;
   chr(8),'\u0008')

valun = strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(m.valun,;
   chr(11),'\u000B'),;
   chr(14),'\u000E'),;
   chr(15),'\u000F'),;
   chr(16),'\u0010'),;
   chr(17),'\u0011'),;
   chr(18),'\u0012'),;
   chr(19),'\u0013'),;
   chr(20),'\u0014'),;
   chr(21),'\u0015')

valun = strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(strtran(m.valun,;
   chr(22),'\u0016'),;
   chr(23),'\u0017'),;
   chr(24),'\u0018'),;
   chr(25),'\u0019'),;
   chr(26),'\u001A'),;
   chr(27),'\u001B'),;
   chr(28),'\u001C'),;
   chr(29),'\u001D'),;
   chr(30),'\u001E'),;
   chr(31),'\u001F')

return m.valun

*---------------------------------------------------------------
*** DH 2026-02-12: accept taProperties and tlNoCollectionName
*Function procCollection(obt,nonullArrayItems,amembersFlag )
Function procCollection(obt,nonullArrayItems,amembersFlag, taProperties, tlNoCollectionName)
*---------------------------------------------------------------

local isCollection

With obt

	nm = .Count

	conllave = .Count > 0 And !Empty(.GetKey(1))

	For x1 = 1 To .Count

		If m.conllave
			elem = Createobject('empty')
			addproperty(elem,'Key', .GetKey(m.x1) )
			addproperty(elem,'Value',.Item(m.x1))
		Else
			elem = .Item(m.x1)
		Endif

		este = m.este+Iif(m.x1>1,','+m.xtabs,'')

		If Vartype(m.elem) # 'O'

			este = m.este+Concatval(m.elem)

		else

			if vartype( m.elem.baseclass ) = 'C' and m.elem.baseclass = 'Collection'
				isCollection = .t.
				este = m.este+'{ '+m.xTabs+'"collection'+collTagName(m.elem)+'" :'
				xTabs = nivel(2)
			else
				isCollection = .f.
				m.este = m.este+'{'
			endif

*** DH 2026-02-12: pass taProperties
*			este = m.este+procObject(m.elem, m.isCollection , m.noNullArrayItem, m.aMembersFlag )
			este = m.este+procObject(m.elem, m.isCollection , m.noNullArrayItem, m.aMembersFlag, @taProperties, tlNoCollectionName)

			este = m.este+'}'

			if m.isCollection
				xTabs = nivel(-2)
				este = m.este+m.xTabs+'}'
			endif

		Endif

	endfor

	este = rtrim(m.este,1,m.xTabs)

Endwith