diff options
Diffstat (limited to 'src/cepis-json.cob')
| -rw-r--r-- | src/cepis-json.cob | 409 |
1 files changed, 409 insertions, 0 deletions
diff --git a/src/cepis-json.cob b/src/cepis-json.cob new file mode 100644 index 0000000..389d488 --- /dev/null +++ b/src/cepis-json.cob @@ -0,0 +1,409 @@ +IDENTIFICATION DIVISION. +PROGRAM-ID. CEPIS-JSON-GET. + +*> --------------------------------------------------------------------- +*> Read one member out of a JSON object. +*> +*> CALL "CEPIS-JSON-GET" USING JSON-TEXT CEPIS-JSON-SCAN +*> +*> Only the members of the object delimited by JS-FROM and JS-TO are +*> considered; nested objects and arrays are skipped whole, so a member +*> named "lat" inside "geo" is not mistaken for a top-level one. Members +*> the caller does not ask about are ignored, which is what lets a new +*> field appear in the API without breaking this client. +*> +*> String values come back with their escapes decoded, including \uXXXX +*> for the whole of Unicode, encoded as UTF-8. +*> --------------------------------------------------------------------- + +DATA DIVISION. +WORKING-STORAGE SECTION. +01 WS-P PIC 9(9). +01 WS-Q PIC 9(9). +01 WS-C PIC X. +01 WS-D PIC X. +01 WS-DEPTH PIC S9(9). +01 WS-IN-STRING PIC X. +01 WS-LEN PIC 9(9). +01 WS-STR PIC X(1024). +01 WS-STR-LEN PIC 9(9). +01 WS-KEY-TEXT PIC X(32). +01 WS-KEY-LEN PIC 9(9). +01 WS-VAL-START PIC 9(9). +01 WS-VAL-END PIC 9(9). +01 WS-VAL-TYPE PIC X. +01 WS-DONE PIC X. +01 WS-CODE PIC 9(9). +01 WS-LOW PIC 9(9). +01 WS-NIB PIC 9(9). +01 WS-B1 PIC 9(9). +01 WS-B2 PIC 9(9). +01 WS-B3 PIC 9(9). +01 WS-B4 PIC 9(9). +01 WS-REST PIC 9(9). +01 WS-HEX-OK PIC X. +01 WS-I PIC 9(9). +01 CONST-QUOTE PIC X VALUE '"'. +01 CONST-BACKSLASH PIC X VALUE "\". + +LINKAGE SECTION. +01 JSON-TEXT PIC X(262144). +COPY "cepis-json.cpy". + +PROCEDURE DIVISION USING JSON-TEXT CEPIS-JSON-SCAN. + +MAIN-START. + MOVE SPACE TO JS-TYPE + MOVE SPACES TO JS-VALUE + MOVE 0 TO JS-VALUE-LEN + MOVE 0 TO JS-VSTART + MOVE 0 TO JS-VEND + MOVE "N" TO WS-DONE + + MOVE JS-FROM TO WS-P + IF WS-P < 1 + MOVE 1 TO WS-P + END-IF + PERFORM SKIP-BLANKS + IF WS-P > JS-TO + MOVE "E" TO JS-TYPE + GOBACK + END-IF + IF JSON-TEXT(WS-P:1) NOT = "{" + MOVE "E" TO JS-TYPE + GOBACK + END-IF + ADD 1 TO WS-P + + PERFORM UNTIL WS-DONE = "Y" OR WS-P > JS-TO + PERFORM SKIP-BLANKS + IF WS-P > JS-TO + MOVE "Y" TO WS-DONE + EXIT PERFORM + END-IF + IF JSON-TEXT(WS-P:1) = "}" + MOVE "Y" TO WS-DONE + EXIT PERFORM + END-IF + IF JSON-TEXT(WS-P:1) NOT = CONST-QUOTE + MOVE "E" TO JS-TYPE + MOVE "Y" TO WS-DONE + EXIT PERFORM + END-IF + + PERFORM READ-STRING + MOVE WS-STR(1:32) TO WS-KEY-TEXT + MOVE WS-STR-LEN TO WS-KEY-LEN + + PERFORM SKIP-BLANKS + IF WS-P > JS-TO OR JSON-TEXT(WS-P:1) NOT = ":" + MOVE "E" TO JS-TYPE + MOVE "Y" TO WS-DONE + EXIT PERFORM + END-IF + ADD 1 TO WS-P + PERFORM SKIP-BLANKS + + MOVE WS-P TO WS-VAL-START + PERFORM SCAN-VALUE + COMPUTE WS-VAL-END = WS-P - 1 + + IF WS-KEY-TEXT = JS-KEY AND WS-KEY-LEN <= 32 + PERFORM TAKE-VALUE + MOVE "Y" TO WS-DONE + EXIT PERFORM + END-IF + + PERFORM SKIP-BLANKS + IF WS-P > JS-TO + MOVE "Y" TO WS-DONE + ELSE + IF JSON-TEXT(WS-P:1) = "," + ADD 1 TO WS-P + ELSE + MOVE "Y" TO WS-DONE + END-IF + END-IF + END-PERFORM + GOBACK. + +*> ------------------------------------------------------------------- +SKIP-BLANKS. + PERFORM UNTIL WS-P > JS-TO + MOVE JSON-TEXT(WS-P:1) TO WS-C + IF WS-C = SPACE OR WS-C = X"09" OR WS-C = X"0A" OR WS-C = X"0D" + ADD 1 TO WS-P + ELSE + EXIT PERFORM + END-IF + END-PERFORM. + +*> ------------------------------------------------------------------- +TAKE-VALUE. + MOVE WS-VAL-TYPE TO JS-TYPE + MOVE WS-VAL-START TO JS-VSTART + MOVE WS-VAL-END TO JS-VEND + IF WS-VAL-TYPE = "S" + MOVE WS-VAL-START TO WS-P + PERFORM READ-STRING + MOVE WS-STR TO JS-VALUE + MOVE WS-STR-LEN TO JS-VALUE-LEN + ELSE + COMPUTE WS-LEN = WS-VAL-END - WS-VAL-START + 1 + IF WS-LEN > 1024 + MOVE 1024 TO WS-LEN + END-IF + IF WS-LEN > 0 + MOVE JSON-TEXT(WS-VAL-START:WS-LEN) TO JS-VALUE + MOVE WS-LEN TO JS-VALUE-LEN + END-IF + END-IF. + +*> ------------------------------------------------------------------- +*> Classify the value at WS-P and step past it. Objects and arrays are +*> walked with a depth counter that is blind inside string literals, so +*> a brace in a street name cannot close the object early. +SCAN-VALUE. + IF WS-P > JS-TO + MOVE "E" TO WS-VAL-TYPE + EXIT PARAGRAPH + END-IF + MOVE JSON-TEXT(WS-P:1) TO WS-C + EVALUATE TRUE + WHEN WS-C = CONST-QUOTE + MOVE "S" TO WS-VAL-TYPE + PERFORM SKIP-STRING + WHEN WS-C = "{" + MOVE "O" TO WS-VAL-TYPE + PERFORM SKIP-NESTED + WHEN WS-C = "[" + MOVE "A" TO WS-VAL-TYPE + PERFORM SKIP-NESTED + WHEN WS-C = "t" OR WS-C = "f" + MOVE "B" TO WS-VAL-TYPE + PERFORM SKIP-BARE + WHEN WS-C = "n" + MOVE "Z" TO WS-VAL-TYPE + PERFORM SKIP-BARE + WHEN OTHER + MOVE "N" TO WS-VAL-TYPE + PERFORM SKIP-BARE + END-EVALUATE. + +*> ------------------------------------------------------------------- +SKIP-BARE. + PERFORM UNTIL WS-P > JS-TO + MOVE JSON-TEXT(WS-P:1) TO WS-C + IF WS-C = "," OR WS-C = "}" OR WS-C = "]" + OR WS-C = SPACE OR WS-C = X"09" OR WS-C = X"0A" OR WS-C = X"0D" + EXIT PERFORM + END-IF + ADD 1 TO WS-P + END-PERFORM. + +*> ------------------------------------------------------------------- +SKIP-STRING. + ADD 1 TO WS-P + PERFORM UNTIL WS-P > JS-TO + MOVE JSON-TEXT(WS-P:1) TO WS-C + IF WS-C = CONST-BACKSLASH + ADD 2 TO WS-P + ELSE + ADD 1 TO WS-P + IF WS-C = CONST-QUOTE + EXIT PERFORM + END-IF + END-IF + END-PERFORM. + +*> ------------------------------------------------------------------- +SKIP-NESTED. + MOVE 0 TO WS-DEPTH + MOVE "N" TO WS-IN-STRING + PERFORM UNTIL WS-P > JS-TO + MOVE JSON-TEXT(WS-P:1) TO WS-C + IF WS-IN-STRING = "Y" + IF WS-C = CONST-BACKSLASH + ADD 2 TO WS-P + ELSE + IF WS-C = CONST-QUOTE + MOVE "N" TO WS-IN-STRING + END-IF + ADD 1 TO WS-P + END-IF + ELSE + EVALUATE TRUE + WHEN WS-C = CONST-QUOTE + MOVE "Y" TO WS-IN-STRING + ADD 1 TO WS-P + WHEN WS-C = "{" OR WS-C = "[" + ADD 1 TO WS-DEPTH + ADD 1 TO WS-P + WHEN WS-C = "}" OR WS-C = "]" + SUBTRACT 1 FROM WS-DEPTH + ADD 1 TO WS-P + WHEN OTHER + ADD 1 TO WS-P + END-EVALUATE + IF WS-DEPTH <= 0 + EXIT PERFORM + END-IF + END-IF + END-PERFORM. + +*> ------------------------------------------------------------------- +*> Read the string literal starting at WS-P into WS-STR, decoding the +*> escapes, and leave WS-P just past the closing quote. +READ-STRING. + MOVE SPACES TO WS-STR + MOVE 0 TO WS-STR-LEN + ADD 1 TO WS-P + PERFORM UNTIL WS-P > JS-TO + MOVE JSON-TEXT(WS-P:1) TO WS-C + IF WS-C = CONST-QUOTE + ADD 1 TO WS-P + EXIT PERFORM + END-IF + IF WS-C = CONST-BACKSLASH + ADD 1 TO WS-P + IF WS-P > JS-TO + EXIT PERFORM + END-IF + MOVE JSON-TEXT(WS-P:1) TO WS-D + EVALUATE WS-D + WHEN "n" + MOVE X"0A" TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + WHEN "t" + MOVE X"09" TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + WHEN "r" + MOVE X"0D" TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + WHEN "b" + MOVE X"08" TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + WHEN "f" + MOVE X"0C" TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + WHEN "u" + PERFORM APPEND-UNICODE + WHEN OTHER + MOVE WS-D TO WS-C + PERFORM APPEND-CHAR + ADD 1 TO WS-P + END-EVALUATE + ELSE + PERFORM APPEND-CHAR + ADD 1 TO WS-P + END-IF + END-PERFORM. + +*> ------------------------------------------------------------------- +APPEND-CHAR. + IF WS-STR-LEN < 1024 + ADD 1 TO WS-STR-LEN + MOVE WS-C TO WS-STR(WS-STR-LEN:1) + END-IF. + +*> ------------------------------------------------------------------- +*> WS-P sits on the "u" of a \uXXXX escape. Decode it, join it with the +*> escape that follows when the two form a surrogate pair, and append the +*> UTF-8 bytes. +APPEND-UNICODE. + ADD 1 TO WS-P + MOVE 0 TO WS-CODE + PERFORM READ-HEX-4 + IF WS-HEX-OK NOT = "Y" + EXIT PARAGRAPH + END-IF + IF WS-CODE >= 55296 AND WS-CODE <= 56319 + IF WS-P + 5 <= JS-TO + AND JSON-TEXT(WS-P:1) = CONST-BACKSLASH + AND JSON-TEXT(WS-P + 1:1) = "u" + MOVE WS-CODE TO WS-LOW + ADD 2 TO WS-P + MOVE 0 TO WS-CODE + PERFORM READ-HEX-4 + IF WS-HEX-OK = "Y" AND WS-CODE >= 56320 AND WS-CODE <= 57343 + COMPUTE WS-CODE = + 65536 + (WS-LOW - 55296) * 1024 + (WS-CODE - 56320) + END-IF + END-IF + END-IF + PERFORM EMIT-UTF8. + +*> ------------------------------------------------------------------- +READ-HEX-4. + MOVE "Y" TO WS-HEX-OK + PERFORM VARYING WS-I FROM 1 BY 1 UNTIL WS-I > 4 + IF WS-P > JS-TO + MOVE "N" TO WS-HEX-OK + EXIT PERFORM + END-IF + MOVE JSON-TEXT(WS-P:1) TO WS-D + EVALUATE TRUE + WHEN WS-D >= "0" AND WS-D <= "9" + COMPUTE WS-NIB = FUNCTION ORD(WS-D) - FUNCTION ORD("0") + WHEN WS-D >= "a" AND WS-D <= "f" + COMPUTE WS-NIB = FUNCTION ORD(WS-D) - FUNCTION ORD("a") + 10 + WHEN WS-D >= "A" AND WS-D <= "F" + COMPUTE WS-NIB = FUNCTION ORD(WS-D) - FUNCTION ORD("A") + 10 + WHEN OTHER + MOVE "N" TO WS-HEX-OK + EXIT PERFORM + END-EVALUATE + COMPUTE WS-CODE = WS-CODE * 16 + WS-NIB + ADD 1 TO WS-P + END-PERFORM. + +*> ------------------------------------------------------------------- +EMIT-UTF8. + EVALUATE TRUE + WHEN WS-CODE < 128 + MOVE FUNCTION CHAR(WS-CODE + 1) TO WS-C + PERFORM APPEND-CHAR + WHEN WS-CODE < 2048 + DIVIDE WS-CODE BY 64 GIVING WS-B1 REMAINDER WS-B2 + COMPUTE WS-B1 = 192 + WS-B1 + COMPUTE WS-B2 = 128 + WS-B2 + MOVE FUNCTION CHAR(WS-B1 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B2 + 1) TO WS-C + PERFORM APPEND-CHAR + WHEN WS-CODE < 65536 + DIVIDE WS-CODE BY 4096 GIVING WS-B1 REMAINDER WS-REST + DIVIDE WS-REST BY 64 GIVING WS-B2 REMAINDER WS-B3 + COMPUTE WS-B1 = 224 + WS-B1 + COMPUTE WS-B2 = 128 + WS-B2 + COMPUTE WS-B3 = 128 + WS-B3 + MOVE FUNCTION CHAR(WS-B1 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B2 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B3 + 1) TO WS-C + PERFORM APPEND-CHAR + WHEN OTHER + DIVIDE WS-CODE BY 262144 GIVING WS-B1 REMAINDER WS-REST + DIVIDE WS-REST BY 4096 GIVING WS-B2 REMAINDER WS-Q + DIVIDE WS-Q BY 64 GIVING WS-B3 REMAINDER WS-B4 + COMPUTE WS-B1 = 240 + WS-B1 + COMPUTE WS-B2 = 128 + WS-B2 + COMPUTE WS-B3 = 128 + WS-B3 + COMPUTE WS-B4 = 128 + WS-B4 + MOVE FUNCTION CHAR(WS-B1 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B2 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B3 + 1) TO WS-C + PERFORM APPEND-CHAR + MOVE FUNCTION CHAR(WS-B4 + 1) TO WS-C + PERFORM APPEND-CHAR + END-EVALUATE. + +END PROGRAM CEPIS-JSON-GET. |