Project

General

Profile

json.p

Igor Skornyakov, 03/30/2023 12:53 PM

Download (13 KB)

 
1
DEFINE TEMP-TABLE tt-1 NO-UNDO
2
    NAMESPACE-URI "http://goldencode.com/testNamespace5" 
3
//    NAMESPACE-PREFIX "fwdPrefix1"  
4
    FIELD a1char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char-attr" XML-NODE-NAME 'pk' SERIALIZE-NAME 'char' XML-NODE-TYPE 'attribute' 
5
    FIELD a1int AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-DATA-TYPE 'long' XML-NODE-TYPE  'attribute'
6
    FIELD f1char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char" XML-NODE-NAME 'char-node' SERIALIZE-NAME 'char-field'
7
    FIELD f1charcs  AS CHAR FORMAT "XXXX" INITIAL 'aa88' CASE-SENSITIVE LABEL "char-cs" 
8
    FIELD f1decimal AS DECIMAL FORMAT "->>,>>9.99" HELP 'help' DECIMALS 2 LABEL "decimal" COLUMN-LABEL "decimal-column"
9
    FIELD f1int AS INT BGCOLOR 12 DCOLOR 9 FGCOLOR 14 PFCOLOR 16 FONT 1 MOUSE-POINTER 'cross' FORMAT "99999" INITIAL 1 LABEL "int" 
10
    FIELD f1int1 AS INT  INITIAL 1 LABEL "int1" XML-NODE-TYPE 'hidden' 
11
    FIELD f1int64 AS INT64 FORMAT "99999" EXTENT 4 INITIAL 4 LABEL "int64" SERIALIZE-NAME 'int64-field'  
12
    FIELD f1bool AS LOGICAL INITIAL TRUE LABEL "bool" SERIALIZE-NAME 'logical'
13
    FIELD f1date AS DATE INITIAL TODAY LABEL "date"
14
    FIELD f1datetime AS DATETIME INITIAL NOW  LABEL "datetime"
15
    FIELD f1datetime-tz AS DATETIME-TZ INITIAL NOW LABEL "datetime-tz"
16
    // FIELD f1datetime-tz1 AS DATETIME-TZ INITIAL "10/17/2022 13:47:48.426+03:00" LABEL "datetime-tz1"
17
    FIELD f1blob AS BLOB LABEL "blob" COLUMN-LABEL "blob-column"
18
    FIELD f1clob1 AS CLOB LABEL "clob1" TTCODEPAGE XML-NODE-TYPE 'hidden'
19
    FIELD f1clob2 AS CLOB LABEL "clob2" COLUMN-CODEPAGE 'ibm850' 
20
    FIELD f1recid AS RECID LABEL "recid" FORMAT "->,>>>,>>9"
21
    FIELD f1handle AS HANDLE LABEL "handle" FORMAT ">>>>>>9"
22
    FIELD f1com-handle AS COM-HANDLE LABEL "com-handle" FORMAT ">>>>>>9"
23
    FIELD f1raw AS RAW
24
    FIELD f1rowid AS ROWID
25
    FIELD a1int1 AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-NODE-TYPE  'attribute'
26
    INDEX i1dx1 f1char
27
    INDEX i1dx2 a1char DESC f1char DESC
28
    INDEX i1dx3 AS UNIQUE f1int 
29
.
30

    
31
DEFINE TEMP-TABLE tt2 NO-UNDO
32
    NAMESPACE-URI "http://goldencode.com/testNamespace2"
33
//    NAMESPACE-PREFIX "fwdPrefix2"
34
    FIELD a2char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char-attr" XML-NODE-NAME 'pk' SERIALIZE-NAME 'char' XML-NODE-TYPE 'attribute' 
35
    FIELD a2int AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-DATA-TYPE 'long' XML-NODE-TYPE  'attribute'
36
    FIELD f2char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char" XML-NODE-NAME 'char-node' SERIALIZE-NAME 'char-field'
37
    FIELD f2charcs  AS CHAR FORMAT "XXXX" INITIAL 'aa88' CASE-SENSITIVE LABEL "char-cs" 
38
    FIELD f2decimal AS DECIMAL FORMAT "->>,>>9.9999" HELP 'help' DECIMALS 2 LABEL "decimal" COLUMN-LABEL "decimal-column"
39
    FIELD f2int AS INT BGCOLOR 12 DCOLOR 9 FGCOLOR 14 PFCOLOR 16 FONT 1 MOUSE-POINTER 'cross' FORMAT "99999" INITIAL 1 LABEL "int" 
40
    FIELD f2int1 AS INT  INITIAL 1 LABEL "int1" XML-NODE-TYPE 'hidden' 
41
    FIELD f2int64 AS INT64 FORMAT "99999" INITIAL 4 LABEL "int64" SERIALIZE-NAME 'int64-field'  
42
    FIELD f2bool AS LOGICAL INITIAL TRUE LABEL "bool" SERIALIZE-NAME 'logical'
43
    INDEX i2dx1 f2char
44
    INDEX i2dx2 a2char DESC f2char DESC
45
    INDEX i2dx3 AS UNIQUE f2int 
46
.
47

    
48
DEFINE TEMP-TABLE tt3 NO-UNDO
49
    NAMESPACE-URI "http://goldencode.com/testNamespace2"
50
    NAMESPACE-PREFIX "fwdPrefix3"
51
    FIELD a3char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char-attr" XML-NODE-NAME 'pk' SERIALIZE-NAME 'char' XML-NODE-TYPE 'attribute' 
52
    FIELD a3int AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-DATA-TYPE 'long' XML-NODE-TYPE  'attribute'
53
    FIELD f3char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char" XML-NODE-NAME 'char-node' SERIALIZE-NAME 'char-field'
54
    FIELD f3charcs  AS CHAR FORMAT "XXXX" INITIAL 'aa88' CASE-SENSITIVE LABEL "char-cs" 
55
    FIELD f3decimal AS DECIMAL FORMAT "->>,>>9.9999" HELP 'help' DECIMALS 2 LABEL "decimal" COLUMN-LABEL "decimal-column"
56
    FIELD f3int AS INT BGCOLOR 12 DCOLOR 9 FGCOLOR 14 PFCOLOR 16 FONT 1 MOUSE-POINTER 'cross' FORMAT "99999" INITIAL 1 LABEL "int" 
57
    FIELD f3int1 AS INT  INITIAL 1 LABEL "int1" XML-NODE-TYPE 'hidden' 
58
    FIELD f3int64 AS INT64 FORMAT "99999" INITIAL 4 LABEL "int64" SERIALIZE-NAME 'int64-field'  
59
    FIELD f3bool AS LOGICAL INITIAL TRUE LABEL "bool" SERIALIZE-NAME 'logical'
60
    INDEX i3dx1 f3char
61
    INDEX i3dx2 a3char DESC f3char DESC
62
    INDEX i3dx3 AS UNIQUE f3int 
63
.
64

    
65
DEFINE TEMP-TABLE tt4 NO-UNDO
66
    NAMESPACE-URI "http://goldencode.com/testNamespace5"
67
//    NAMESPACE-PREFIX "fwdPrefix4"
68
    FIELD a4char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char-attr" XML-NODE-NAME 'pk' SERIALIZE-NAME 'char' XML-NODE-TYPE 'attribute' 
69
    FIELD a4int AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-DATA-TYPE 'long' XML-NODE-TYPE  'attribute'
70
    FIELD f4char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char" XML-NODE-NAME 'char-node' SERIALIZE-NAME 'char-field'
71
    FIELD f4charcs  AS CHAR FORMAT "XXXX" INITIAL 'aa88' CASE-SENSITIVE LABEL "char-cs" 
72
    FIELD f4decimal AS DECIMAL FORMAT "->>,>>9.9999" HELP 'help' DECIMALS 2 LABEL "decimal" COLUMN-LABEL "decimal-column"
73
    FIELD f4int AS INT BGCOLOR 12 DCOLOR 9 FGCOLOR 14 PFCOLOR 16 FONT 1 MOUSE-POINTER 'cross' FORMAT "99999" INITIAL 1 LABEL "int" 
74
    FIELD f4int1 AS INT  INITIAL 1 LABEL "int1" XML-NODE-TYPE 'hidden' 
75
    FIELD f4int64 AS INT64 FORMAT "99999" INITIAL 4 LABEL "int64" SERIALIZE-NAME 'int64-field'  
76
    FIELD f4bool AS LOGICAL INITIAL TRUE LABEL "bool" SERIALIZE-NAME 'logical'
77
    INDEX i4dx1 f4char
78
    INDEX i4dx2 a4char DESC f4char DESC
79
    INDEX i4dx3 AS UNIQUE f4int 
80
.
81

    
82
DEFINE TEMP-TABLE tt5 NO-UNDO
83
    NAMESPACE-URI "http://goldencode.com/testNamespace5"
84
    NAMESPACE-PREFIX "fwdPrefix5"
85
    FIELD a5char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char-attr" XML-NODE-NAME 'pk' SERIALIZE-NAME 'char' XML-NODE-TYPE 'attribute' 
86
    FIELD a5int AS INT FORMAT "99999" INITIAL 1 LABEL "int-attr" XML-DATA-TYPE 'long' XML-NODE-TYPE  'attribute'
87
    FIELD f5char  AS CHAR FORMAT "XXXX" INITIAL '99aa' LABEL "char" XML-NODE-NAME 'char-node' SERIALIZE-NAME 'char-field'
88
    FIELD f5charcs  AS CHAR FORMAT "XXXX" INITIAL 'aa88' CASE-SENSITIVE LABEL "char-cs" 
89
    FIELD f5decimal AS DECIMAL FORMAT "->>,>>9.9999" HELP 'help' DECIMALS 2 LABEL "decimal" COLUMN-LABEL "decimal-column"
90
    FIELD f5int AS INT BGCOLOR 12 DCOLOR 9 FGCOLOR 14 PFCOLOR 16 FONT 1 MOUSE-POINTER 'cross' FORMAT "99999" INITIAL 1 LABEL "int" 
91
    FIELD f5int1 AS INT  INITIAL 1 LABEL "int1" XML-NODE-TYPE 'hidden' 
92
    FIELD f5int64 AS INT64 FORMAT "99999" INITIAL 4 LABEL "int64" SERIALIZE-NAME 'int64-field'  
93
    FIELD f5bool AS LOGICAL INITIAL TRUE LABEL "bool" SERIALIZE-NAME 'logical'
94
    INDEX i5dx1 f5char
95
    INDEX i5dx2 a5char DESC f5char DESC
96
    INDEX i5dx3 AS UNIQUE f5int 
97
.
98

    
99
DEFINE DATASET ds
100
    NAMESPACE-URI "http://goldencode.com/testNamespace" 
101
    NAMESPACE-PREFIX "fwdPrefix"
102
    FOR tt-1, tt2, tt3, tt4, tt5
103
    DATA-RELATION rel12 FOR tt-1, tt2 RELATION-FIELDS(f1int, f2int) NESTED 
104
    DATA-RELATION rel13 FOR tt-1, tt3 RELATION-FIELDS(f1int, f3int) NESTED 
105
    DATA-RELATION rel34 FOR tt3, tt4 RELATION-FIELDS(f3int, f4int) NESTED 
106
    DATA-RELATION rel51 FOR tt5, tt-1 RELATION-FIELDS(f5int, f1int) NESTED 
107
.
108
    
109
DEF VAR dsh AS HANDLE NO-UNDO.
110
DEF VAR hds AS HANDLE NO-UNDO.
111
DEF VAR hds1 AS HANDLE NO-UNDO.
112
DEF VAR hdss AS HANDLE NO-UNDO.
113
DEF VAR tth1 AS HANDLE NO-UNDO.
114
DEF VAR tth2 AS HANDLE NO-UNDO.
115
DEF VAR ttdh AS HANDLE NO-UNDO.
116
DEF VAR lRet AS LOGICAL NO-UNDO.
117
DEF VAR nmsg AS INTEGER NO-UNDO.
118
DEF VAR n AS INTEGER NO-UNDO.
119

    
120
OUTPUT TO 'json-test/json-marshal.txt'.
121

    
122
CREATE tt-1. tt-1.f1char = '1.1111'. tt-1.f1int = 11. tt-1.f1decimal = 3.1465.
123
CREATE tt-1. tt-1.f1char = '1.2222'. tt-1.f1int = 12. tt-1.f1decimal = 3.1415926.
124

    
125
CREATE tt2. tt2.f2char = '2.1111'. tt2.f2int = 11. tt2.f2decimal = 3.1415.
126
CREATE tt2. tt2.f2char = '2.2222'. tt2.f2int = 22. tt2.f2decimal = 3.141515926.
127

    
128
CREATE tt3. tt3.f3char = '3.1111'. tt3.f3int = 11. tt3.f3decimal = 3.1415.
129
CREATE tt3. tt3.f3char = '3.2222'. tt3.f3int = 32. tt3.f3decimal = 3.141515926.
130

    
131
CREATE tt4. tt4.f4char = '4.1111'. tt4.f4int = 11. tt4.f4decimal = 3.1415.
132
CREATE tt4. tt4.f4char = '4.2222'. tt4.f4int = 42. tt4.f4decimal = 3.141515926.
133

    
134
CREATE tt5. tt5.f5char = '5.1111'. tt5.f5int = 11. tt5.f5decimal = 3.1415.
135
CREATE tt5. tt5.f5char = '5.2222'. tt5.f5int = 52. tt5.f5decimal = 3.141515926.
136

    
137
DEFINE STREAM json.
138
DEF VAR json-ptr AS MEMPTR NO-UNDO.
139
DEF VAR json-lc AS LONGCHAR NO-UNDO.
140

    
141
CREATE DATASET hds.
142
CREATE DATASET hds1.
143
CREATE DATASET hdss.
144
CREATE TEMP-TABLE ttdh.
145

    
146
dsh = DATASET ds:HANDLE. 
147

    
148
tth1 = TEMP-TABLE tt-1:HANDLE. 
149
tth2 = TEMP-TABLE tt2:HANDLE. 
150

    
151
// FILE
152
lRet = tth1:WRITE-JSON('file', 'json-test/tth1.json', TRUE, ?, FALSE, FALSE) NO-ERROR.
153
RUN show-error('tth1:WRITE-JSON to FILE').
154
MESSAGE 'tth1:WRITE-JSON' lRet.
155

    
156
lRet = ttdh:READ-JSON('file', 'json-test/tth1.json', 'empty') NO-ERROR.
157
RUN show-error('ttdh:READ-JSON from FILE').
158
MESSAGE 'ttdh:READ-JSON' lRet.
159

    
160
IF lRet THEN DO:
161
    lRet = ttdh:WRITE-JSON('file', 'json-test/ttdh.json', TRUE, ?, FALSE, FALSE).
162
    MESSAGE 'ttdh:WRITE-JSON' lRet.
163
END.
164

    
165
// MEMPTR
166
lRet = tth1:WRITE-JSON('memptr', json-ptr, TRUE, ?, FALSE, FALSE) NO-ERROR.
167
RUN show-error('tth1:WRITE-JSON to MEMPTR').
168
MESSAGE 'tth1:WRITE-JSON to MEMPTR' lRet.
169

    
170
CREATE TEMP-TABLE ttdh.
171
lRet = ttdh:READ-JSON('memptr', json-ptr, 'empty') NO-ERROR.
172
RUN show-error('ttdh:READ-JSON from MEMPTR').
173
MESSAGE 'ttdh:READ-JSON from MEMPTR' lRet.
174

    
175
IF lRet THEN DO:
176
    lRet = ttdh:WRITE-JSON('file', 'json-test/ttdh-ptr.json', TRUE, ?, FALSE, FALSE).
177
    MESSAGE 'ttdh:WRITE-JSON.ptr' lRet.
178
END.
179

    
180
 SET-SIZE(json-ptr) = 0.
181
 
182
// LONGCHAR
183
lRet = tth1:WRITE-JSON('longchar', json-lc, TRUE, ?, FALSE, FALSE) NO-ERROR.
184
RUN show-error('tth1:WRITE-JSON to LONGCHAR').
185
MESSAGE 'tth1:WRITE-JSON to LONGCHAR' lRet.
186

    
187
CREATE TEMP-TABLE ttdh.
188
lRet = ttdh:READ-JSON('longchar', json-lc, 'empty') NO-ERROR.
189
RUN show-error('ttdh:READ-JSON from LONGCHAR').
190
MESSAGE 'ttdh:READ-JSON from LONGCHAR' lRet.
191

    
192
IF lRet THEN DO:
193
    lRet = ttdh:WRITE-JSON('file', 'json-test/ttdh-lc.json', TRUE, ?, FALSE, FALSE).
194
    MESSAGE 'ttdh:WRITE-JSON.lc' lRet.
195
    lRet = ttdh:WRITE-XMLSCHEMA('file', 'json-test/ttdh-lc.xsd', TRUE,  'UTF-8', FALSE, FALSE).
196
    MESSAGE 'ttdh:WRITE-XMLSCHEMA' lRet.
197
END.
198

    
199
// STREAM
200
OUTPUT STREAM json TO 'json-test/tth1-stream.json'.
201
lRet = tth1:WRITE-JSON('stream', 'json', TRUE, ?, FALSE, FALSE) NO-ERROR.
202
RUN show-error('tth1:WRITE-JSON to STREAM').
203
MESSAGE 'tth1:WRITE-JSON to STREAM' lRet.
204
OUTPUT STREAM json CLOSE.
205

    
206
CREATE TEMP-TABLE ttdh.
207
INPUT STREAM json FROM 'json-test/tth1-stream.json'.
208
lRet = ttdh:READ-JSON('stream', 'json', 'empty') NO-ERROR.
209
RUN show-error('ttdh:READ-JSON from STREAM').
210
MESSAGE 'ttdh:READ-JSON from STREAM' lRet.
211
INPUT STREAM json CLOSE.
212

    
213
IF lRet THEN DO:
214
    lRet = ttdh:WRITE-JSON('file', 'json-test/ttdh-stream.json', TRUE, ?, FALSE, FALSE).
215
    MESSAGE 'ttdh:WRITE-JSON' lRet.
216
END.
217

    
218
// --------------------------
219

    
220
lRet = dsh:WRITE-JSON('file', 'json-test/ds.json', TRUE, ?, FALSE, FALSE).
221
MESSAGE 'dsh:WRITE-JSON' lRet.
222

    
223
lRet = hdss:READ-JSON('file', 'json-test/ds.json', 'empty') NO-ERROR.
224
RUN show-error('hdss:READ-JSON').
225
MESSAGE 'hdss:READ-JSON' lRet.
226

    
227
lRet = hdss:WRITE-XMLSCHEMA('file', 'json-test/hdss.xsd', TRUE,  'UTF-8', FALSE, FALSE).
228
MESSAGE 'hdss:WRITE-XMLSCHEMA' lRet.
229

    
230
lRet = hdss:WRITE-JSON('file', 'json-test/hdss.json', TRUE, ?, FALSE, FALSE).
231
MESSAGE 'hdss:WRITE-JSON' lRet.
232

    
233
DEF VAR htt AS HANDLE NO-UNDO.
234
n = 1.
235
DO WHILE n <= hdss:NUM-BUFFERS.
236
    htt = hdss:GET-BUFFER-HANDLE(n).
237
    lRet = htt:WRITE-JSON('file', 'json-test/hdss:.1-' + STRING(n) + '.json', TRUE, ?, FALSE, FALSE).
238
    MESSAGE 'hdss:' + STRING(n) + ':WRITE-JSON.1' lRet.
239
    n = n + 1.
240
END.
241

    
242
DEF VAR hr AS HANDLE NO-UNDO.
243
n = 1.
244
DO WHILE n <= hdss:NUM-RELATIONS.
245
    hr = hdss:GET-RELATION(n).
246
    MESSAGE hr:NAME "NESTED:" hr:NESTED "PARENT-ID-RELATION:" hr:PARENT-ID-RELATION "RELATION-FIELDS: [" + hr:RELATION-FIELDS + "]".
247
    n = n + 1.
248
END.
249

    
250
dsh:EMPTY-DATASET().
251
MESSAGE 'dsh:EMPTY-DATASET' lRet.
252

    
253
lRet = dsh:READ-JSON('file', 'json-test/ds.json', 'empty') NO-ERROR.
254
RUN show-error('dsh:READ-JSON').
255
MESSAGE 'dsh:READ-JSON.1' lRet.
256

    
257
lRet = dsh:WRITE-JSON('file', 'json-test/ds.1.json', TRUE, ?, FALSE, FALSE).
258
MESSAGE 'dsh:WRITE-JSON.1' lRet.
259

    
260
n = 1.
261
DO WHILE n <= dsh:NUM-BUFFERS.
262
    htt = dsh:GET-BUFFER-HANDLE(n).
263
    lRet = htt:WRITE-JSON('file', 'json-test/ds.1-' + STRING(n) + '.json', TRUE, ?, FALSE, FALSE).
264
    MESSAGE 'dsh' + STRING(n) + ':WRITE-JSON.1' lRet.
265
    n = n + 1.
266
END.
267

    
268
OUTPUT CLOSE.
269

    
270
PROCEDURE show-error:
271
    DEF INPUT PARAM action AS CHAR.
272

    
273
    MESSAGE "After" action ": error =" ERROR-STATUS:ERROR 
274
            "num-messages =" ERROR-STATUS:NUM-MESSAGES 
275
            "type =" ERROR-STATUS:TYPE 
276
            .
277
    IF ERROR-STATUS:NUM-MESSAGES > 0 THEN DO:
278
        DO nmsg = 1 TO ERROR-STATUS:NUM-MESSAGES:
279
          MESSAGE "***" ERROR-STATUS:GET-NUMBER(nmsg) ':' ERROR-STATUS:GET-MESSAGE(nmsg).
280
        END.
281
    END.                      
282
END.