Initial importv0.1.0

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.