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.