*------------------------------------------------------------------- * Created by Marco Plaza vfp2nofox@gmail.com / @vfp2Nofox * ver 2.000 - 26/03/2016 * ver 2.090 - 22/07/2016 : * improved error management * nfjsonread will return .null. for invalid json *------------------------------------------------------------------- Lparameters cjsonstr,isFileName,reviveCollection #Define crlf Chr(13)+Chr(10) Private All stackLevels=Astackinfo(aerrs) If m.stackLevels > 1 calledFrom = 'called From '+aerrs(m.stackLevels-1,4)+' line '+Transform(aerrs(m.stackLevels-1,5)) Else calledFrom = '' Endif oJson = nfJsonCreate2(cjsonstr,isFileName,reviveCollection) Return Iif(Vartype(m.oJson)='O',m.oJson,.Null.) *------------------------------------------------------------------------- Function nfJsonCreate2(cjsonstr,isFileName,reviveCollection) *------------------------------------------------------------------------- * validate parameters: Do Case Case ; Vartype(m.cjsonstr) # 'C' Or; Vartype(m.reviveCollection) # 'L' Or ; Vartype(m.isFileName) # 'L' jERROR('invalid parameter type') Case m.isFileName And !File(m.cjsonstr) jERROR('File "'+Rtrim(Left(m.cjsonstr,255))+'" does not exist') Endcase * process json: If m.isFileName cjsonstr = Filetostr(m.cjsonstr) Endif cJson = Rtrim(Chrtran(m.cjsonstr,Chr(13)+Chr(9)+Chr(10),'')) pChar = Left(Ltrim(m.cJson),1) nl = Alines(aj,m.cJson,20,'{','}','"',',',':','[',']') For xx = 1 To Alen(aj) If Left(Ltrim(aj(m.xx)),1) $ '{}",:[]' Or Left(Ltrim(m.aj(m.xx)),4) $ 'true/false/null' aj(m.xx) = Ltrim(aj(m.xx)) Endif Endfor Try x = 1 cError = '' oStack = Createobject('stack') oJson = Createobject('empty') Do Case Case aj(1)='{' x = 1 oStack.pushObject() procstring(m.oJson) Case aj(1) = '[' x = 0 procstring(m.oJson,.T.) Otherwise Error 'Invalid Json: expecting [{ received '+m.pChar Endcase If m.reviveCollection oJson = reviveCollection(m.oJson) Endif Catch To oerr strp = '' For Y = 1 To m.x strp = m.strp+aj(m.y) Endfor Do Case Case oerr.ErrorNo = 1098 cError = ' Invalid Json: '+ m.oerr.Message+crlf+' Parsing: '+Right(m.strp,80) *+' program line: '+Transform(oerr.Lineno)+' array item '+Transform(m.x) Case oerr.ErrorNo = 2034 cError = ' INVALID DATE: '+crlf+' Parsing: '+Right(m.strp,80) Otherwise cError = 'program error # '+Transform(m.oerr.ErrorNo)+crlf+m.oerr.Message+' at: '+Transform(oerr.Lineno)+crlf+' Parsing ('+Transform(m.x)+') ' Endcase Endtry If !Empty(m.cError) jERROR(m.cError) Endif Return m.oJson *------------------------------------------------ Procedure jERROR( cMessage ) *------------------------------------------------ Error 'nfJson ('+m.calledFrom+'):'+crlf+m.cMessage Return To nfJsonRead *-------------------------------------------------------------------------------- Procedure procstring(obj,eValue) *-------------------------------------------------------------------------------- #Define cvalid 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890_' #Define creem '_______________________________________________________________' Private rowpos,colpos,bidim,ncols,arrayName,expecting,arrayLevel,vari Private expectingPropertyName,expectingValue,objectOpen expectingPropertyName = !m.eValue expectingValue = m.eValue expecting = Iif(expectingPropertyName,'"}','') objectOpen = .T. bidim = .F. colpos = 0 rowpos = 0 arrayLevel = 0 arrayName = '' vari = '' ncols = 0 Do While m.objectOpen x = m.x+1 Do Case Case m.x > m.nl m.x = m.nl If oStack.Count > 0 Error 'expecting '+m.expecting Endif Return Case aj(m.x) = '}' And '}' $ m.expecting closeObject() Case aj(x) = ']' And ']' $ m.expecting closeArray() Case m.expecting = ':' If aj(m.x) = ':' expecting = '' Loop Else Error 'expecting : received '+aj(m.x) Endif Case ',' $ m.expecting Do Case Case aj(x) = ',' expecting = Iif( '[' $ m.expecting , '[' , '' ) Case Not aj(m.x) $ m.expecting Error 'expecting '+m.expecting+' received '+aj(m.x) Otherwise expecting = Strtran(m.expecting,',','') Endcase Case m.expectingPropertyName If aj(m.x) = '"' propertyName(m.obj) Else Error 'expecting "'+m.expecting+' received '+aj(m.x) Endif Case m.expectingValue If m.expecting == '[' And m.aj(m.x) # '[' Error 'expecting [ received '+aj(m.x) Else procValue(m.obj) Endif Endcase Enddo *---------------------------------------------------------- Function anuevoel(obj,arrayName,valasig,bidim,colpos,rowpos) *---------------------------------------------------------- If m.bidim colpos = m.colpos+1 If colpos > m.ncols ncols = m.colpos Endif Dimension obj.&arrayName(m.rowpos,m.ncols) obj.&arrayName(m.rowpos,m.colpos) = m.valasig If Vartype(m.valasig) = 'O' procstring(obj.&arrayName(m.rowpos,m.colpos)) Endif Else rowpos = m.rowpos+1 Dimension obj.&arrayName(m.rowpos) obj.&arrayName(m.rowpos) = m.valasig If Vartype(m.valasig) = 'O' procstring(obj.&arrayName(m.rowpos)) Endif Endif *----------------------------------------- Function unescunicode( Value ) *----------------------------------------- noc=1 Do While .T. posunicode = At('\u',m.value,m.noc) If m.posunicode = 0 Return Endif If Substr(m.value,m.posunicode-1,1) = '\' And Substr(m.value,m.posunicode-2,1) # '\' noc=m.noc+1 Loop Endif nunic = Evaluate('0x'+ Substr(m.value,m.posunicode+2,4) ) If Between(m.nunic,0,255) unicodec = Chr(m.nunic) Else unicodec = '&#'+Transform(m.nunic)+';' Endif Value = Stuff(m.value,m.posunicode,6,m.unicodec) Enddo *----------------------------------- Function unescapecontrolc( Value ) *----------------------------------- If At('\', m.value) = 0 Return Endif * unescape special characters: Private aa,elem,unesc Declare aa(1) =Alines(m.aa,m.value,18,'\\','\b','\f','\n','\r','\t','\"','\/') unesc ='' #Define sustb 'bnrt/"' #Define sustr Chr(127)+Chr(10)+Chr(13)+Chr(9)+Chr(47)+Chr(34) For Each elem In m.aa If ! m.elem == '\\' And Right(m.elem,2) = '\' elem = Left(m.elem,Len(m.elem)-2)+Chrtran(Right(m.elem,1),sustb,sustr) Endif unesc = m.unesc+m.elem Endfor Value = m.unesc *-------------------------------------------- Procedure propertyName(obj) *-------------------------------------------- vari='' Do While ( Right(m.vari,1) # '"' Or ( Right(m.vari,2) = '\"' And Right(m.vari,3) # '\\"' ) ) And Alen(aj) > m.x x=m.x+1 vari = m.vari+aj(m.x) Enddo If Right(m.vari,1) # '"' Error ' expecting " received '+ Right(Rtrim(m.vari),1) Endif vari = Left(m.vari,Len(m.vari)-1) vari = Iif(Isalpha(m.vari),'','_')+m.vari vari = Chrtran( vari, Chrtran( vari, cvalid,'' ) , creem ) If vari = 'tabindex' vari = '_tabindex' Endif expecting = ':' expectingValue = .T. expectingPropertyName = .F. *------------------------------------------------------------- Procedure procValue(obj) *------------------------------------------------------------- Do Case Case aj(m.x) = '{' oStack.pushObject() If m.arrayLevel = 0 AddProperty(obj,m.vari,Createobject('empty')) procstring(obj.&vari) expectingPropertyName = .T. expecting = ',}' expectingValue = .F. Else anuevoel(m.obj,m.arrayName,Createobject('empty'),m.bidim,@colpos,@rowpos) expectingPropertyName = .F. expecting = ',]' expectingValue = .T. Endif Case aj(x) = '[' oStack.pushArray() Do Case Case m.arrayLevel = 0 arrayName = Evl(m.vari,'array') rowpos = 0 colpos = 0 bidim = .F. #DEFINE EMPTYARRAYFLAG '_EMPTY_ARRAY_FLAG_' Try AddProperty(obj,(m.arrayName+'(1)'),EMPTYARRAYFLAG) Catch m.arrayName = m.arrayName+'_vfpSafe_' AddProperty(obj,(m.arrayName+'(1)'),EMPTYARRAYFLAG) Endtry Case m.arrayLevel = 1 And !m.bidim rowpos = 1 colpos = 0 ncols = 1 Dime obj.&arrayName(1,2) bidim = .T. Endcase arrayLevel = m.arrayLevel+1 vari='' expecting = Iif(!m.bidim,'[]{',']') expectingValue = .T. expectingPropertyName = .F. Otherwise isstring = aj(m.x)='"' x = m.x + Iif(m.isstring,1,0) Value = '' Do While .T. Value = m.value+m.aj(m.x) If m.isstring If Right(m.value,1) = '"' And ( Right(m.value,2) # '\"' Or Right(m.value,3) = '\\' ) Exit Endif Else If Right(m.value,1) $ '}],' And ( Left(Right(m.value,2),1) # '\' Or Left(Right(Value,3),2) = '\\') Exit Endif Endif If m.x < Alen(aj) x = m.x+1 Else Exit Endif Enddo closeChar = Right(m.value,1) Value = Rtrim(m.value,1,m.closeChar) If Empty(Value) And Not ( m.isstring And m.closeChar = '"' ) Error 'Expecting value received '+m.closeChar Endif Do Case Case m.isstring If m.closeChar # '"' Error 'expecting " received '+m.closeChar Endif Case oStack.isObject() And Not m.closeChar $ ',}' Error 'expecting ,} received '+m.closeChar Case oStack.isArray() And Not m.closeChar $ ',]' Error 'expecting ,] received '+m.closeChar Endcase If m.isstring * don't change this lines sequence!: unescunicode(@Value) && 1 unescapecontrolc(@Value) && 2 Value = Strtran(m.value,'\\','\') && 3 ** check for Json Date: If isJsonDt( m.value ) Value = jsonDateToDT( m.value ) Endif Else Value = Alltrim(m.value) Do Case Case m.value == 'null' Value = .Null. Case m.value == 'true' Or m.value == 'false' Value = Value='true' Case Empty(Chrtran(m.value,'-1234567890.E','')) And Occurs('.',m.value) <= 1 And Occurs('-',m.value) <= 1 And Occurs('E',m.value)<=1 If Not 'E' $ m.value Value = Cast( m.value As N( Len(m.value) , Iif(At('.',m.value)>0,Len(m.value)-At( '.',m.value) ,0) )) Endif Otherwise Error 'expecting "|number|null|true|false| received '+aj(m.x) Endcase Endif If m.arrayLevel = 0 AddProperty(obj,m.vari,m.value) expecting = '}' expectingValue = .F. expectingPropertyName = .T. Else anuevoel(obj,m.arrayName,m.value,m.bidim,@colpos,@rowpos) expecting = ']' expectingValue = .T. expectingPropertyName = .F. Endif expecting = Iif(m.isstring,',','')+m.expecting Do Case Case m.closeChar = ']' closeArray() Case m.closeChar = '}' closeObject() Endcase Endcase *------------------------------ Function closeArray() *------------------------------ If oStack.Pop() # 'A' Error 'unexpected ] ' Endif If m.arrayLevel = 0 Error 'unexpected ] ' Endif arrayLevel = m.arrayLevel-1 If m.arrayLevel = 0 arrayName = '' rowpos = 0 colpos = 0 expecting = Iif(oStack.isObject(),',}','') expectingPropertyName = .T. expectingValue = .F. Else If m.bidim rowpos = m.rowpos+1 colpos = 0 expecting = ',][' Else expecting = ',]' Endif expectingValue = .T. expectingPropertyName = .F. Endif *------------------------------------- Procedure closeObject *------------------------------------- If oStack.Pop() # 'O' Error 'unexpected }' Endif If m.arrayLevel = 0 expecting = ',}' expectingValue = .F. expectingPropertyName = .T. objectOpen = .F. Else expecting = ',]' expectingValue = .T. expectingPropertyName = .F. Endif *---------------------------------------------- Function reviveCollection( o ) *---------------------------------------------- Private All oConv = Createobject('empty') nProp = Amembers(elem,m.o,0,'U') For x = 1 To m.nProp estaVar = m.elem(x) esArray = .F. esColeccion = Type('m.o.'+m.estaVar) = 'O' And Right( m.estaVar , 14 ) $ '_KV_COLLECTION,_KL_COLLECTION' And Type( 'm.o.'+m.estaVar+'.collectionitems',1) = 'A' Do Case Case m.esColeccion estaProp = Createobject('collection') tv = m.o.&estaVar m.keyValColl = Right( m.estaVar , 14 ) = '_KV_COLLECTION' For T = 1 To Alen(m.tv.collectionItems) If m.keyValColl esteval = m.tv.collectionItems(m.T).Value Else esteval = m.tv.collectionItems(m.T) ENDIF IF VARTYPE(m.esteval) = 'C' AND m.esteval = emptyarrayflag loop ENDIF If Vartype(m.esteval) = 'O' Or Type('esteVal',1) = 'A' esteval = reviveCollection(m.esteval) Endif If m.keyValColl estaProp.Add(esteval,m.tv.collectionItems(m.T).Key) Else estaProp.Add(m.esteval) Endif Endfor Case Type('m.o.'+m.estaVar,1) = 'A' esArray = .T. For T = 1 To Alen(m.o.&estaVar) Dimension &estaVar(m.T) If Type('m.o.&estaVar(m.T)') = 'O' &estaVar(m.T) = reviveCollection(m.o.&estaVar(m.T)) Else &estaVar(m.T) = m.o.&estaVar(m.T) Endif Endfor Case Type('m.o.'+estaVar) = 'O' estaProp = reviveCollection(m.o.&estaVar) Otherwise estaProp = m.o.&estaVar Endcase estaVar = Strtran( m.estaVar,'_KV_COLLECTION', '' ) estaVar = Strtran( m.estaVar, '_KL_COLLECTION', '' ) Do Case Case m.esColeccion AddProperty(m.oConv,m.estaVar,m.estaProp) Case m.esArray AddProperty(m.oConv,m.estaVar+'(1)') Acopy(&estaVar,m.oConv.&estaVar) Otherwise AddProperty(m.oConv,m.estaVar,m.estaProp) Endcase Endfor Try retCollection = m.oConv.Collection.BaseClass = 'Collection' Catch retCollection = .F. Endtry If m.retCollection Return m.oConv.Collection Else Return m.oConv Endif *---------------------------------- Function isJsonDt( cstr ) *---------------------------------- Return Iif( Len(m.cstr) = 19 ; AND Len(Chrtran(m.cstr,'01234567890:T-','')) = 0 ; and Substr(m.cstr,5,1) = '-' ; and Substr(m.cstr,8,1) = '-' ; and Substr(m.cstr,11,1) = 'T' ; and Substr(m.cstr,14,1) = ':' ; and Substr(m.cstr,17,1) = ':' ; and Occurs('T',m.cstr) = 1 ; and Occurs('-',m.cstr) = 2 ; and Occurs(':',m.cstr) = 2 ,.T.,.F. ) *----------------------------------- Procedure jsonDateToDT( cJsonDate ) *----------------------------------- Return Eval("{^"+m.cJsonDate+"}") ****************************************** Define Class Stack As Collection ****************************************** *--------------------------- Function pushObject() *--------------------------- This.Add('O') *--------------------------- Function pushArray() *--------------------------- This.Add('A') *-------------------------------------- Function isObject() *-------------------------------------- If This.Count > 0 Return This.Item( This.Count ) = 'O' Else Return .F. Endif *-------------------------------------- Function isArray() *-------------------------------------- If This.Count > 0 Return This.Item( This.Count ) = 'A' Else Return .F. Endif *---------------------------- Function Pop() *---------------------------- cret = This.Item( This.Count ) This.Remove( This.Count ) Return m.cret ****************************************** Enddefine ******************************************