romfast/gomag-vending
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

commit initial

Browse Source 
testare api gomag vending master
This commit is contained in:
Marius
2025-08-26 23:01:45 +03:00
parent b7e7a20d99
commit 5b9ec542cc
5 changed files with 1600 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

71
CLAUDE.md Normal file
View File

@@ -0,0 +1,71 @@
# CLAUDE.md
This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository.
## Project Overview
This is a Visual FoxPro 9 project that interfaces with the GoMag e-commerce API. The main component is a script for retrieving product data from GoMag's REST API endpoints.
## Architecture
- **Single File Application**: `gomag-vending.prg` - Main Visual FoxPro script
- **Technology**: Visual FoxPro 9 with WinHttp.WinHttpRequest.5.1 for HTTP requests
- **API Integration**: GoMag REST API v1 for product management
## Core Components
### gomag-vending.prg
Main script that handles:
- GoMag API authentication using Apikey and ApiShop headers
- HTTP GET requests to retrieve product data
- JSON response parsing and analysis
- File output for API responses (timestamped .json files)
- Error handling and connectivity testing
### Key Configuration Variables
- `lcApiUrl`: GoMag API endpoint (defaults to product read endpoint)
- `lcApiKey`: GoMag API key (must be configured)
- `lcApiShop`: Shop URL (must be configured)
## Development Commands
### Running the Application
```foxpro
DO gomag-vending.prg
```
### Testing Connectivity
The script includes a `TestConnectivity()` function for internet connectivity testing.
## API Integration Details
### Authentication
- Uses header-based authentication with `Apikey` and `ApiShop` headers
- Requires User-Agent to be different from "PostmanRuntime"
### Endpoints Used
- Primary: `https://api.gomag.ro/api/v1/product/read/json?enabled=1`
- Supports pagination, filtering by category/brand, and sorting parameters
### Rate Limiting
- No specific limitations for READ requests
- POST requests limited to ~1 request per second (Leaky Bucket algorithm)
## File Structure
```
/
├── gomag-vending.prg # Main application script
└── gomag_products_*.json # Generated API response files (timestamped)
```
## Configuration Requirements
Before running, update these variables in `gomag-vending.prg:10-15`:
1. `lcApiKey` - Your GoMag API key
2. `lcApiShop` - Your shop URL (e.g., "https://yourstore.gomag.ro")
## Helper Functions
- `ParseJsonResponse()` - Basic JSON structure analysis
- `TestConnectivity()` - Internet connectivity testing
- `UrlEncode()` - URL parameter encoding utility

373
gomag-vending-test.prg Normal file
View File

@@ -0,0 +1,373 @@
*-- Script Visual FoxPro 9 pentru accesul la GoMag API cu paginare completa
*-- Autor: Claude AI
*-- Data: 26.08.2025
*-- Setari principale
LOCAL lcApiBaseUrl, lcApiUrl, lcApiKey, lcUserAgent, lcContentType
LOCAL loHttp, lcResponse, lcJsonResponse
LOCAL laHeaders[10], lnHeaderCount
Local lcApiShop, lcCsvFileName, lcErrorResponse, lcFileName, lcLogContent, lcLogFileName, lcPath
Local lcStatusText, lnStatusCode, loError
Local lnLimit, lnCurrentPage, llHasMorePages, loAllJsonData, lnTotalPages, lnTotalProducts
PRIVATE gcAppPath, loJsonData
gcAppPath = ADDBS(JUSTPATH(SYS(16,0)))
SET DEFAULT TO (m.gcAppPath)
lcPath = gcAppPath + 'nfjson;'
SET PATH TO (m.lcPath) ADDITIVE
SET PROCEDURE TO nfjsonread.prg ADDITIVE
*-- Configurare API - MODIFICA aceste valori conform documentatiei GoMag
lcApiBaseUrl = "https://api.gomag.ro/api/v1/product/read/json?enabled=1" && URL de baza pentru lista de produse
lcApiKey = "4c5e46df8f6c4f054fe2787de7a13d4a" && Cheia ta API de la GoMag
lcApiShop = "https://www.coffeepoint.ro" && URL-ul magazinului tau (ex: http://yourdomain.gomag.ro)
lcUserAgent = "Mozilla/5.0" && User-Agent diferit de PostmanRuntime conform documentatiei
lcContentType = "application/json"
lnLimit = 100 && Numarul maxim de produse per pagina (1-100)
lnCurrentPage = 1 && Pagina de start
llHasMorePages = .T. && Flag pentru paginare
loAllJsonData = NULL && Obiect pentru toate datele
*-- Verificare daca avem WinHttp disponibil
TRY
loHttp = CREATEOBJECT("WinHttp.WinHttpRequest.5.1")
CATCH TO loError
? "Eroare la crearea obiectului WinHttp: " + loError.Message
RETURN .F.
ENDTRY
*-- Bucla pentru preluarea tuturor produselor (paginare)
loAllJsonData = CREATEOBJECT("Empty")
ADDPROPERTY(loAllJsonData, "products", CREATEOBJECT("Empty"))
ADDPROPERTY(loAllJsonData, "total", 0)
ADDPROPERTY(loAllJsonData, "pages", 0)
lnTotalProducts = 0
DO WHILE llHasMorePages
*-- Construire URL cu paginare
lcApiUrl = lcApiBaseUrl + "&page=" + TRANSFORM(lnCurrentPage) + "&limit=" + TRANSFORM(lnLimit)
? "Preluare pagina " + TRANSFORM(lnCurrentPage) + "..."
*-- Configurare request
TRY
*-- Initializare request GET
loHttp.Open("GET", lcApiUrl, .F.)
*-- Setare headers conform documentatiei GoMag
loHttp.SetRequestHeader("User-Agent", lcUserAgent)
loHttp.SetRequestHeader("Content-Type", lcContentType)
loHttp.SetRequestHeader("Accept", "application/json")
loHttp.SetRequestHeader("Apikey", lcApiKey) && Header pentru API Key
loHttp.SetRequestHeader("ApiShop", lcApiShop) && Header pentru shop URL
*-- Setari timeout
loHttp.SetTimeouts(30000, 30000, 30000, 30000) && 30 secunde pentru fiecare
*-- Trimitere request
loHttp.Send()
*-- Verificare status code
lnStatusCode = loHttp.Status
lcStatusText = loHttp.StatusText
IF lnStatusCode = 200
*-- Success - preluare raspuns
lcResponse = loHttp.ResponseText
*-- Parsare JSON cu nfjson
SET PATH TO nfjson ADDITIVE
loJsonData = nfJsonRead(lcResponse)
IF !ISNULL(loJsonData)
*-- Prima pagina - setam informatiile generale
IF lnCurrentPage = 1
IF TYPE('loJsonData.total') = 'C' OR TYPE('loJsonData.total') = 'N'
loAllJsonData.total = VAL(TRANSFORM(loJsonData.total))
ENDIF
IF TYPE('loJsonData.pages') = 'C' OR TYPE('loJsonData.pages') = 'N'
loAllJsonData.pages = VAL(TRANSFORM(loJsonData.pages))
ENDIF
? "Total produse: " + TRANSFORM(loAllJsonData.total)
? "Total pagini: " + TRANSFORM(loAllJsonData.pages)
ENDIF
*-- Adaugare produse din pagina curenta
IF TYPE('loJsonData.products') = 'O'
DO MergeProducts WITH loAllJsonData, loJsonData
ENDIF
*-- Verificare daca mai sunt pagini
IF TYPE('loJsonData.pages') = 'C' OR TYPE('loJsonData.pages') = 'N'
lnTotalPages = VAL(TRANSFORM(loJsonData.pages))
IF lnCurrentPage >= lnTotalPages
llHasMorePages = .F.
ENDIF
ELSE
*-- Daca nu avem info despre pagini, verificam daca sunt produse
IF TYPE('loJsonData.products') != 'O'
llHasMorePages = .F.
ENDIF
ENDIF
lnCurrentPage = lnCurrentPage + 1
ELSE
*-- Salvare raspuns JSON raw in caz de eroare de parsare
lcFileName = "gomag_error_page" + TRANSFORM(lnCurrentPage) + "_" + DTOS(DATE()) + "_" + STRTRAN(TIME(), ":", "") + ".json"
STRTOFILE(lcResponse, lcFileName)
llHasMorePages = .F.
ENDIF
ELSE
*-- Eroare HTTP - salvare in fisier de log
lcLogFileName = "gomag_error_page" + TRANSFORM(lnCurrentPage) + "_" + DTOS(DATE()) + "_" + STRTRAN(TIME(), ":", "") + ".log"
lcLogContent = "HTTP Error " + TRANSFORM(lnStatusCode) + ": " + lcStatusText + CHR(13) + CHR(10)
*-- Incearca sa citesti raspunsul pentru detalii despre eroare
TRY
lcErrorResponse = loHttp.ResponseText
IF !EMPTY(lcErrorResponse)
lcLogContent = lcLogContent + "Error Details:" + CHR(13) + CHR(10) + lcErrorResponse
ENDIF
CATCH
lcLogContent = lcLogContent + "Could not read error details"
ENDTRY
STRTOFILE(lcLogContent, lcLogFileName)
llHasMorePages = .F.
ENDIF
CATCH TO loError
*-- Salvare erori in fisier de log pentru pagina curenta
lcLogFileName = "gomag_error_page" + TRANSFORM(lnCurrentPage) + "_" + DTOS(DATE()) + "_" + STRTRAN(TIME(), ":", "") + ".log"
lcLogContent = "Script Error on page " + TRANSFORM(lnCurrentPage) + ":" + CHR(13) + CHR(10) +;
"Error Number: " + TRANSFORM(loError.ErrorNo) + CHR(13) + CHR(10) +;
"Error Message: " + loError.Message + CHR(13) + CHR(10) +;
"Error Line: " + TRANSFORM(loError.LineNo)
STRTOFILE(lcLogContent, lcLogFileName)
llHasMorePages = .F.
ENDTRY
*-- Pauza scurta intre cereri pentru a evita rate limiting
IF llHasMorePages
INKEY(1) && Pauza de 1 secunda
ENDIF
ENDDO
*-- Creare fisier CSV cu toate produsele
IF !ISNULL(loAllJsonData) AND TYPE('loAllJsonData.products') = 'O'
lcCsvFileName = "gomag_all_products_" + DTOS(DATE()) + "_" + STRTRAN(TIME(), ":", "") + ".csv"
DO CreateCsvFromJson WITH loAllJsonData, lcCsvFileName
? "Fisier CSV creat: " + lcCsvFileName
*-- Salvare si a datelor JSON complete
lcJsonFileName = "gomag_all_products_" + DTOS(DATE()) + "_" + STRTRAN(TIME(), ":", "") + ".json"
DO SaveCompleteJson WITH loAllJsonData, lcJsonFileName
? "Fisier JSON complet creat: " + lcJsonFileName
ENDIF
*-- Curatare
loHttp = NULL
*-- Functie pentru unirea produselor din toate paginile
PROCEDURE MergeProducts
PARAMETERS tloAllData, tloPageData
LOCAL lnPropCount, lnIndex, lcPropName, loProduct
*-- Verifica daca avem produse in pagina curenta
IF TYPE('tloPageData.products') = 'O'
*-- Itereaza prin toate produsele din pagina
lnPropCount = AMEMBERS(laPageProducts, tloPageData.products, 0)
FOR lnIndex = 1 TO lnPropCount
lcPropName = laPageProducts(lnIndex)
loProduct = EVALUATE('tloPageData.products.' + lcPropName)
IF TYPE('loProduct') = 'O'
*-- Adauga produsul la colectia principala
ADDPROPERTY(tloAllData.products, lcPropName, loProduct)
ENDIF
ENDFOR
ENDIF
ENDPROC
*-- Functie pentru salvarea datelor JSON complete
PROCEDURE SaveCompleteJson
PARAMETERS tloJsonData, tcFileName
LOCAL lcJsonContent
*-- Construieste JSON simplu pentru salvare
lcJsonContent = '{' + CHR(13) + CHR(10)
lcJsonContent = lcJsonContent + ' "total": ' + TRANSFORM(tloJsonData.total) + ',' + CHR(13) + CHR(10)
lcJsonContent = lcJsonContent + ' "pages": ' + TRANSFORM(tloJsonData.pages) + ',' + CHR(13) + CHR(10)
lcJsonContent = lcJsonContent + ' "products": {' + CHR(13) + CHR(10)
*-- Adauga produsele (versiune simplificata)
LOCAL lnPropCount, lnIndex, lcPropName, loProduct
lnPropCount = AMEMBERS(laProducts, tloJsonData.products, 0)
FOR lnIndex = 1 TO lnPropCount
lcPropName = laProducts(lnIndex)
loProduct = EVALUATE('tloJsonData.products.' + lcPropName)
IF TYPE('loProduct') = 'O'
lcJsonContent = lcJsonContent + ' "' + lcPropName + '": {'
IF TYPE('loProduct.id') = 'C'
lcJsonContent = lcJsonContent + '"id": "' + loProduct.id + '",'
ENDIF
IF TYPE('loProduct.sku') = 'C'
lcJsonContent = lcJsonContent + '"sku": "' + loProduct.sku + '",'
ENDIF
IF TYPE('loProduct.name') = 'C'
lcJsonContent = lcJsonContent + '"name": "' + STRTRAN(loProduct.name, '"', '\"') + '",'
ENDIF
*-- Elimina ultima virgula
IF RIGHT(lcJsonContent, 1) = ','
lcJsonContent = LEFT(lcJsonContent, LEN(lcJsonContent) - 1)
ENDIF
lcJsonContent = lcJsonContent + '}'
IF lnIndex < lnPropCount
lcJsonContent = lcJsonContent + ','
ENDIF
lcJsonContent = lcJsonContent + CHR(13) + CHR(10)
ENDIF
ENDFOR
lcJsonContent = lcJsonContent + ' }' + CHR(13) + CHR(10)
lcJsonContent = lcJsonContent + '}' + CHR(13) + CHR(10)
STRTOFILE(lcJsonContent, tcFileName)
ENDPROC
*-- Functie pentru crearea fisierului CSV din datele JSON
PROCEDURE CreateCsvFromJson
PARAMETERS tloJsonData, tcCsvFileName
LOCAL lcCsvContent, lcCsvHeader, lcCsvRow
LOCAL lnProductCount, lnIndex
LOCAL loProduct
lcCsvContent = ""
lcCsvHeader = "ID,SKU,Name,Brand,Weight,Stock,Base_Price,Price,VAT_Included,Enabled,VAT,Currency,Ecotax" + CHR(13) + CHR(10)
lcCsvContent = lcCsvHeader
*-- Verifica daca avem produse in raspuns
IF TYPE('tloJsonData.products') = 'O'
*-- Itereaza prin toate produsele
lnPropCount = AMEMBERS(laProducts, tloJsonData.products, 0)
? "Procesare " + TRANSFORM(lnPropCount) + " produse pentru CSV..."
FOR lnIndex = 1 TO lnPropCount
lcPropName = laProducts(lnIndex)
loProduct = EVALUATE('tloJsonData.products.' + lcPropName)
IF TYPE('loProduct') = 'O'
*-- Extrage datele produsului
lcCsvRow = ;
IIF(TYPE('loProduct.id')='C', STRTRAN(loProduct.id, ',', ';'), '') + ',' +;
IIF(TYPE('loProduct.sku')='C', STRTRAN(loProduct.sku, ',', ';'), '') + ',' +;
IIF(TYPE('loProduct.name')='C', '"' + STRTRAN(STRTRAN(loProduct.name, '"', '""'), ',', ';') + '"', '') + ',' +;
IIF(TYPE('loProduct.brand')='C', STRTRAN(loProduct.brand, ',', ';'), '') + ',' +;
IIF(TYPE('loProduct.weight')='C', loProduct.weight, IIF(TYPE('loProduct.weight')='N', TRANSFORM(loProduct.weight), '')) + ',' +;
IIF(TYPE('loProduct.stock')='C', loProduct.stock, IIF(TYPE('loProduct.stock')='N', TRANSFORM(loProduct.stock), '')) + ',' +;
IIF(TYPE('loProduct.base_price')='C', loProduct.base_price, IIF(TYPE('loProduct.base_price')='N', TRANSFORM(loProduct.base_price), '')) + ',' +;
IIF(TYPE('loProduct.price')='C', loProduct.price, IIF(TYPE('loProduct.price')='N', TRANSFORM(loProduct.price), '')) + ',' +;
IIF(TYPE('loProduct.vat_included')='C', loProduct.vat_included, IIF(TYPE('loProduct.vat_included')='N', TRANSFORM(loProduct.vat_included), '')) + ',' +;
IIF(TYPE('loProduct.enabled')='C', loProduct.enabled, IIF(TYPE('loProduct.enabled')='N', TRANSFORM(loProduct.enabled), '')) + ',' +;
IIF(TYPE('loProduct.vat')='C', loProduct.vat, IIF(TYPE('loProduct.vat')='N', TRANSFORM(loProduct.vat), '')) + ',' +;
IIF(TYPE('loProduct.currency')='C', loProduct.currency, '') + ',' +;
IIF(TYPE('loProduct.ecotax')='C', loProduct.ecotax, IIF(TYPE('loProduct.ecotax')='N', TRANSFORM(loProduct.ecotax), '')) +;
CHR(13) + CHR(10)
lcCsvContent = lcCsvContent + lcCsvRow
ENDIF
ENDFOR
ENDIF
*-- Salvare fisier CSV
STRTOFILE(lcCsvContent, tcCsvFileName)
? "CSV salvat cu " + TRANSFORM(lnPropCount) + " produse"
ENDPROC
*-- Functii helper pentru testare (optionale)
*-- Test conectivitate internet
FUNCTION TestConnectivity
LOCAL loHttp, llResult
llResult = .T.
TRY
loHttp = CREATEOBJECT("WinHttp.WinHttpRequest.5.1")
loHttp.Open("GET", "https://www.google.com", .F.)
loHttp.SetTimeouts(5000, 5000, 5000, 5000)
loHttp.Send()
IF loHttp.Status != 200
llResult = .F.
ENDIF
CATCH
llResult = .F.
ENDTRY
loHttp = NULL
RETURN llResult
ENDFUNC
*-- Functie pentru codificare URL
FUNCTION UrlEncode
PARAMETERS tcString
LOCAL lcResult, lcChar, lnI
lcResult = ""
FOR lnI = 1 TO LEN(tcString)
lcChar = SUBSTR(tcString, lnI, 1)
DO CASE
CASE ISALPHA(lcChar) OR ISDIGIT(lcChar) OR INLIST(lcChar, "-", "_", ".", "~")
lcResult = lcResult + lcChar
OTHERWISE
lcResult = lcResult + "%" + RIGHT("0" + TRANSFORM(ASC(lcChar), "@0"), 2)
ENDCASE
ENDFOR
RETURN lcResult
ENDFUNC
*-- Scriptul cu paginare completa pentru preluarea tuturor produselor
*-- Caracteristici principale:
*-- - Paginare automata pentru toate produsele (100 per pagina)
*-- - Pauze intre cereri pentru respectarea rate limiting
*-- - Creare fisier CSV cu toate produsele
*-- - Salvare fisier JSON complet cu toate datele
*-- - Logging separat pentru fiecare pagina in caz de eroare
*-- - Afisare progres in timpul executiei
*-- INSTRUCTIUNI DE UTILIZARE:
*-- 1. Modifica lcApiKey cu cheia ta API de la GoMag
*-- 2. Modifica lcApiShop cu URL-ul magazinului tau
*-- 3. Ruleaza scriptul - va prelua automat toate produsele
*-- 4. Verifica fisierele generate: CSV si JSON cu toate produsele
*-- Script completat cu paginare - verificati fisierele generate

381
nfjson/nfjsoncreate.prg Normal file
View File

@@ -0,0 +1,381 @@
*-------------------------------------------------------------------
* Created by Marco Plaza @vfp2Nofox
* ver 1.100 - 24/02/2016
* enabled collection processing
* ver 1.101 - 24/02/2016
* solved indentation on nested collections
* ver 1.110 -11/03/2016
* -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.
* ver 1.120
* encode control characters ( chr(0) ~ chr(31) )
*-----------------------------------------------------------------------
Parameters ovfp,FormattedOutput,nonullarrayitem,crootName,aMembersFlag
#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'
Endif
_nivel = Iif( Cast(m.formattedOutput As l ) , 1, -1)
Do Case
Case esarray
ojson = Createobject('empty')
AddProperty(ojson,'array(1)')
Acopy(ovfp,ojson.Array)
cjson = procobject(ojson,.F.,m.nonullarrayitem,m.aMembersFlag)
cjson = Substr( m.cjson,At('[',m.cjson))
Case Type('oVfp.BaseClass')='C' And ovfp.BaseClass = 'Collection'
cjson = procobject(ovfp,.T.,m.nonullarrayitem,m.aMembersFlag)
crootName = Evl(m.crootName,'collection')
cjson = '{"'+m.crootName+collTagName(ovfp)+'": '+cjson+'}'+Iif(FormattedOutput,crlf,'')+'}'
Otherwise
cjson = '{'+procobject(ovfp,.F.,m.nonullarrayitem,m.aMembersFlag)+'}'
Endcase
Return Ltrim(cjson)
*----------------------------------------
Function collTagName(thiscoll)
*----------------------------------------
Return Iif( m.thiscoll.Count > 0 And !Empty( m.thiscoll.GetKey(1) ), '_kv_collection','_kl_collection' )
*----------------------------------------------------------------------------------
Function procobject(obt,iscollection,nonullarrayitem,aMembersFlag)
*----------------------------------------------------------------------------------
If Isnull(obt)
Return 'null'
Endif
Private All Except _nivel
este = ''
xtabs = nivel(2)
bc = Iif(Type('m.obt.class')='C',m.obt.Class,'?')
iscollection = bc = 'Collection'
If m.iscollection
este = este+'{ '+xtabs
xtabs = nivel(2)
este = este+'"collectionitems": ['+xtabs
procCollection(obt,m.nonullarrayitem,m.aMembersFlag)
xtabs = nivel(-2)
este = este+xtabs+']'
Else
Amembers(am,m.obt,0,m.aMembersFlag)
If Vartype(m.am) = 'U'
xtabs=m.nivel(-2)
Return ''
Endif
nm = Alen(am)
For x1 = 1 To m.nm
Var = Lower(am(m.x1))
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
procarray(obt,m.var,m.nonullarrayitem)
Case m.esobjeto
thiso=m.obt.&Var
bc = Iif(Type('m.thiso.class')='C',m.thiso.Class,'?')
If bc = 'Collection'
este = Rtrim(m.este,1,'":')+ collTagName( m.thiso )+'":'
este = m.este+procobject(m.obt.&Var,.T.,m.nonullarrayitem,m.aMembersFlag)+[}]
Else
este = m.este+[{]+procobject(m.obt.&Var,.F.,m.nonullarrayitem,m.aMembersFlag)+[}]
Endif
Otherwise
este = este+concatval(m.obt.&Var)
Endcase
Endfor
Endif
xtabs = nivel(-2)
este = este+m.xtabs
Return m.este
*----------------------------------------------------
Procedure procarray(obt,arrayName,nonullarrayitem)
*----------------------------------------------------
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 nelem <= m.titems
este = 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.class')='C',m.elem.Class,'?')
If bc = 'Collection'
este = m.este+' { "collection'+ collTagName( m.elem )+'":'
este = m.este+procobject(m.elem ,.T.,m.nonullarrayitem,m.aMembersFlag)
este = este + '}'+m.xtabs+'}'
Else
este = m.este+[{]+procobject(m.elem ,.F.,m.nonullarrayitem,m.aMembersFlag)+[}]
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(12)+Chr(10)+Chr(13)+Chr(9)+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<63>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)+["]
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(m.valun,'\','\\')
valun = Strtran(m.valun,'"','\"')
*valun = Strtran(m.valun,'/','\/')
If !mustEncode(m.valun)
Return
Endif
valun = Strtran(m.valun,Chr(127),'\b')
valun = Strtran(m.valun,Chr(12),'\f')
valun = Strtran(m.valun,Chr(10),'\n')
valun = Strtran(m.valun,Chr(13),'\r')
valun = Strtran(m.valun,Chr(9),'\t')
If !mustEncode(m.valun)
Return
Endif
Local x
For x = 0 To 31
valun = Strtran(m.valun,Chr(m.x),'\u'+Right(Transform(m.x,'@0'),4))
Endfor
Return Rtrim(m.valun)
*---------------------------------------------------------------
Function procCollection(obt,nonullArrayItems,aMembersFlag )
*---------------------------------------------------------------
Local iscollection
With obt
nm = .Count
conllave = .Count > 0 And !Empty(.GetKey(1))
For x1 = 1 To .Count
If conllave
elem = Createobject('empty')
AddProperty(elem,'Key', .GetKey(x1) )
AddProperty(elem,'Value',.Item(x1))
Else
elem = .Item(x1)
Endif
este = este+Iif(x1>1,','+xtabs,'')
If Vartype(elem) # 'O'
este = 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
este = este+procobject(m.elem, m.iscollection , m.nonullarrayitem, m.aMembersFlag )
este = este+'}'
If m.iscollection
xtabs = nivel(-2)
este = este+m.xtabs+'}'
Endif
Endif
Endfor
este = Rtrim(m.este,1,m.xtabs)
Endwith

BIN
nfjson/nfjsonread.FXP Normal file
View File

Binary file not shown.

775
nfjson/nfjsonread.prg Normal file
View File

@@ -0,0 +1,775 @@
*-------------------------------------------------------------------
* 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
******************************************