XLFJSOND ;SLC/KCM/TJB - Decode JSON ;26 Oct 2016
;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
DECODE(XUJSON,XUROOT,XUERR) ; Set JSON object into closed array ref XUROOT
;
DIRECT ; TAG for use by DECODE^XLFJSON
;
; Examples: D DECODE^XLFJSON("MYJSON","LOCALVAR","LOCALERR")
; D DECODE^XLFJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
;
; XUJSON: string/array containing serialized JSON object
; XUROOT: closed array reference for M representation of object
; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
;
; XUIDX: points to next character in JSON string to process
; XUSTACK: manages stack of subscripts
; XUPROP: true if next string is property name, otherwise treat as value
;
N XUMAX S XUMAX=4000 ; limit document lines to 4000 characters
S XUERR=$G(XUERR,"^TMP(""XLFJERR"",$J)")
; If a simple string is passed in, move it to an temp array (XUINPUT)
; so that the processing is consistently on an array.
I $D(@XUJSON)=1 N XUINPUT S XUINPUT(1)=@XUJSON,XUJSON="XUINPUT"
S XUROOT=$NA(@XUROOT@("Z")),XUROOT=$E(XUROOT,1,$L(XUROOT)-4) ; make open array ref
N XULINE,XUIDX,XUSTACK,XUPROP,XUVAL,XUTYPE,XUERRORS
S XULINE=$O(@XUJSON@("")),XUIDX=1,XUSTACK=0,XUPROP=0,XUVAL=1,XUERRORS=0
F S XUTYPE=$$NXTKN() Q:XUTYPE="" D I XUERRORS Q
. I XUVAL S XUVAL=0 I ("}],:"[XUTYPE) D ERRX("NOV",XUTYPE) Q ; value was expected
. I XUTYPE="{" S XUSTACK=XUSTACK+1,XUSTACK(XUSTACK)="",XUPROP=1 D:XUSTACK>64 ERRX("STL{") Q
. I XUTYPE="}" D QUIT
. . I +XUSTACK(XUSTACK)=XUSTACK(XUSTACK),XUSTACK(XUSTACK) D ERRX("OBM") ; Numeric and true only
. . S XUSTACK=XUSTACK-1 D:XUSTACK<0 ERRX("SUF}")
. I XUTYPE="[" S XUSTACK=XUSTACK+1,XUSTACK(XUSTACK)=1 D:XUSTACK>64 ERRX("STL[") Q
. I XUTYPE="]" D:'XUSTACK(XUSTACK) ERRX("ARM") S XUSTACK=XUSTACK-1 D:XUSTACK<0 ERRX("SUF]") Q
. I XUTYPE="," D Q
. . I +XUSTACK(XUSTACK)=XUSTACK(XUSTACK),XUSTACK(XUSTACK) S XUSTACK(XUSTACK)=XUSTACK(XUSTACK)+1 ; VEN/SMH - next in array
. . E S XUPROP=1 ; or next property name
. I XUTYPE=":" S XUPROP=0,XUVAL=1 D:'$L($G(XUSTACK(XUSTACK))) ERRX("MPN") Q
. I XUTYPE="""" D Q
. . I XUPROP S XUSTACK(XUSTACK)=$$NAMPARS() I 1
. . E D ADDSTR
. S XUTYPE=$TR(XUTYPE,"TFN","tfn")
. I XUTYPE="t" D SETBOOL("t") Q
. I XUTYPE="f" D SETBOOL("f") Q
. I XUTYPE="n" D SETBOOL("n") Q
. I "0123456789+-.eE"[XUTYPE D SETNUM(XUTYPE) Q ;S @$$CURNODE()=$$NUMPARS(XUTYPE) Q
. D ERRX("TKN",XUTYPE)
I XUSTACK'=0 D ERRX("SCT",XUSTACK)
Q
NXTKN() ; Move the pointers to the beginning of the next token
N XUDONE,XUEOF,XUTOKEN
S XUDONE=0,XUEOF=0 F D Q:XUDONE!XUEOF ; eat spaces & new lines until next visible char
. I XUIDX>$L(@XUJSON@(XULINE)) S XULINE=$O(@XUJSON@(XULINE)),XUIDX=1 I 'XULINE S XUEOF=1 Q
. I $A(@XUJSON@(XULINE),XUIDX)>32 S XUDONE=1 Q
. S XUIDX=XUIDX+1
Q:XUEOF "" ; we're at the end of input
S XUTOKEN=$E(@XUJSON@(XULINE),XUIDX),XUIDX=XUIDX+1
Q XUTOKEN
;
ADDSTR ; Add string value to current node, escaping text along the way
; Expects XULINE,XUIDX to reference that starting point of the index
; TODO: add a mechanism to specify names that should not be escaped
; just store as ":")= and ":",n)=
;
; Happy path -- we find the end quote in the same line
N XUEND,XUX
S XUEND=$F(@XUJSON@(XULINE),"""",XUIDX)
I XUEND,($E(@XUJSON@(XULINE),XUEND-2)'="\") D SETSTR QUIT ;normal
I XUEND,$$ISCLOSEQ(XULINE) D SETSTR QUIT ;close quote preceded by escaped \
;
; Less happy path -- first quote wasn't close quote
N XUDONE,XUTLINE
S XUDONE=0,XUTLINE=XULINE ; XUTLINE for temporary increment of XULINE
F D Q:XUDONE Q:XUERRORS
. ;if no quote on current line advance line, scan again
. I 'XUEND S XUTLINE=XUTLINE+1,XUEND=1 I '$D(@XUJSON@(XUTLINE)) D ERRX("EIQ") Q
. S XUEND=$F(@XUJSON@(XUTLINE),"""",XUEND)
. Q:'XUEND ; continue on to next line if no quote found on this one
. I (XUEND>2),($E(@XUJSON@(XUTLINE),XUEND-2)'="\") S XUDONE=1 Q ; found quote position
. S XUDONE=$$ISCLOSEQ(XUTLINE) ; see if this is an escaped quote or closing quote
Q:XUERRORS
; unescape from XUIDX to XUEND, using \-extension nodes as necessary
D UESEXT
; now we need to move XULINE and XUIDX to next parsing point
S XULINE=XUTLINE,XUIDX=XUEND
Q
SETSTR ; Set simple string value from within same line
; expects XUJSON, XULINE, XUINX, XUEND
N XUX
S XUX=$E(@XUJSON@(XULINE),XUIDX,XUEND-2),XUIDX=XUEND
S @$$CURNODE()=$$UES(XUX)
; "\s" node indicates value is really a string in case value
; collates as numeric or equals boolean keywords
I XUX']]$C(1) S @$$CURNODE()@("\s")=""
I XUX="true"!(XUX="false")!(XUX="null") S @$$CURNODE()@("\s")=""
I XUIDX>$L(@XUJSON@(XULINE)) S XULINE=XULINE+1,XUIDX=1
Q
UESEXT ; unescape from XULINE,XUIDX to XUTLINE,XUEND & extend (\) if necessary
; expects XULINE,XUIDX,XUTLINE,XUEND
N XUI,XUY,XUSTART,XUSTOP,XUDONE,XUBUF,XUNODE,XUMORE,XUTO
S XUNODE=$$CURNODE(),XUBUF="",XUMORE=0,XUSTOP=XUEND-2
S XUI=XUIDX,XUY=XULINE,XUDONE=0
F D Q:XUDONE Q:XUERRORS
. S XUSTART=XUI,XUI=$F(@XUJSON@(XUY),"\",XUI)
. ; if we are on the last line, don't extract past XUSTOP
. I (XUY=XUTLINE) S XUTO=$S('XUI:XUSTOP,XUI>XUSTOP:XUSTOP,1:XUI-2) I 1
. E S XUTO=$S('XUI:99999,1:XUI-2)
. D ADDBUF($E(@XUJSON@(XUY),XUSTART,XUTO))
. I (XUY'<XUTLINE),(('XUI)!(XUI>XUSTOP)) S XUDONE=1 QUIT ; now past close quote
. I 'XUI S XUY=XUY+1,XUI=1 QUIT ; nothing escaped, go to next line
. I XUI>$L(@XUJSON@(XUY)) S XUY=XUY+1,XUI=1 I '$D(@XUJSON@(XUY)) D ERRX("EIU")
. N XUTGT S XUTGT=$E(@XUJSON@(XUY),XUI)
. I XUTGT="u" D I 1
. . N XUTGTC S XUTGTC=$E(@XUJSON@(XUY),XUI+1,XUI+4),XUI=XUI+4
. . I $L(XUTGTC)<4 S XUY=XUY+1,XUI=4-$L(XUTGTC),XUTGTC=XUTGTC_$E(@XUJSON@(XUY),1,XUI)
. . D ADDBUF($C($$DEC^XLFUTL(XUTGTC,16)))
. E D ADDBUF($$REALCHAR(XUTGT))
. S XUI=XUI+1
. I (XUY'<XUTLINE),(XUI>XUSTOP) S XUDONE=1 ; XUI incremented past stop
Q:XUERRORS
D SAVEBUF
Q
ADDBUF(XUX) ; add buffer of characters to destination
; expects XUBUF,XUMAX,XUNODE,XUMORE to be defined
; used directly by ADDSTR
I $L(XUX)+$L(XUBUF)>XUMAX D SAVEBUF
S XUBUF=XUBUF_XUX
Q
SAVEBUF ; write out buffer to destination
; expects XUBUF,XUMAX,XUNODE,XUMORE to be defined
; used directly by ADDSTR,ADDBUF
I XUMORE S @XUNODE@("\",XUMORE)=XUBUF
I 'XUMORE S @XUNODE=XUBUF I $L(XUBUF)<19,+$E(XUBUF,1,18) S @XUNODE@("\s")=""
S XUMORE=XUMORE+1,XUBUF=""
Q
ISCLOSEQ(XUBLINE) ; return true if this is a closing, rather than escaped, quote
; expects
; XUJSON: lines of the JSON encoded string
; XUIDX: points to 1st character of the segment
; XULINE: points to the line in which the segment starts
; XUEND: points to 1st character after the " (may be past the end of the line)
; used directly by ADDSTR
N XUBS,XUBIDX,XUBDONE
S XUBS=0,XUBIDX=XUEND-2,XUBDONE=0 ; XUBIDX starts at 1st character before quote
; count the backslashes preceding the quote (odd number means the quote was escaped)
F D Q:XUBDONE!XUERRORS
. I XUBIDX<1 D Q ; when XUBIDX<1 go back a line
. . S XUBLINE=XUBLINE-1 I XUBLINE<XULINE D ERRX("RSB") Q
. . S XUBIDX=$L(@XUJSON@(XUBLINE))
. I $E(@XUJSON@(XUBLINE),XUBIDX)'="\" S XUBDONE=1 Q
. S XUBS=XUBS+1,XUBIDX=XUBIDX-1
Q XUBS#2=0 ; XUBS is even if this is a close quote
;
NAMPARS() ; Return parsed name, advancing index past the close quote
; -- This assumes no embedded quotes are in the name itself --
N XUEND,XUDONE,XUNAME
S XUDONE=0,XUNAME=""
F D Q:XUDONE Q:XUERRORS
. S XUEND=$F(@XUJSON@(XULINE),"""",XUIDX)
. I XUEND S XUNAME=XUNAME_$E(@XUJSON@(XULINE),XUIDX,XUEND-2),XUIDX=XUEND,XUDONE=1
. I 'XUEND S XUNAME=XUNAME_$E(@XUJSON@(XULINE),XUIDX,$L(@XUJSON@(XULINE)))
. I 'XUEND!(XUEND>$L(@XUJSON@(XULINE))) S XULINE=XULINE+1,XUIDX=1 I '$D(@XUJSON@(XULINE)) D ERRX("ORN")
; prepend quote if label collates as numeric -- assumes no quotes in label
I XUNAME']]$C(1) S XUNAME=""""""_XUNAME
Q XUNAME
;
SETNUM(XUDIGIT) ; Set numeric along with any necessary modifier
N XUX
S XUX=$$NUMPARS(XUDIGIT)
S @$$CURNODE()=+XUX
; if numeric is exponent, "0.nnn" or "-0.nnn" store original string
I +XUX'=XUX S @$$CURNODE()@("\n")=XUX
Q
NUMPARS(XUDIGIT) ; Return parsed number, advancing index past end of number
; XUIDX intially references the second digit
N XUDONE,XUNUM
S XUDONE=0,XUNUM=XUDIGIT
F D Q:XUDONE Q:XUERRORS
. I '("0123456789+-.eE"[$E(@XUJSON@(XULINE),XUIDX)) S XUDONE=1 Q
. S XUNUM=XUNUM_$E(@XUJSON@(XULINE),XUIDX)
. S XUIDX=XUIDX+1 I XUIDX>$L(@XUJSON@(XULINE)) S XULINE=XULINE+1,XUIDX=1 I '$D(@XUJSON@(XULINE)) D ERRX("OR#")
Q XUNUM
;
SETBOOL(XULTR) ; Parse and set boolean value, advancing index past end of value
N XUDONE,XUBOOL,XUX
S XUDONE=0,XUBOOL=XULTR
F D Q:XUDONE Q:XUERRORS
. S XUX=$TR($E(@XUJSON@(XULINE),XUIDX),"TRUEFALSN","truefalsn")
. I '("truefalsn"[XUX) S XUDONE=1 Q
. S XUBOOL=XUBOOL_XUX
. S XUIDX=XUIDX+1 I XUIDX>$L(@XUJSON@(XULINE)) S XULINE=XULINE+1,XUIDX=1 I '$D(@XUJSON@(XULINE)) D ERRX("ORB")
I XULTR="t",(XUBOOL'="true") D ERRX("EXT",XUTYPE)
I XULTR="f",(XUBOOL'="false") D ERRX("EXF",XUTYPE)
I XULTR="n",(XUBOOL'="null") D ERRX("EXN",XUTYPE)
S @$$CURNODE()=XUBOOL
Q
;
OSETBOOL(XUX) ; set a value and increment XUIDX
S @$$CURNODE()=XUX
S XUIDX=XUIDX+$L(XUX)-1
N XUDIFF S XUDIFF=XUIDX-$L(@XUJSON@(XULINE)) ; in case XUIDX moves to next line
I XUDIFF>0 S XULINE=XULINE+1,XUIDX=XUDIFF I '$D(@XUJSON@(XULINE)) D ERRX("ORB")
Q
CURNODE() ; Return a global/local variable name based on XUSTACK
; Expects XUSTACK to be defined already
N XUI,XUSUBS
S XUSUBS=""
F XUI=1:1:XUSTACK S:XUI>1 XUSUBS=XUSUBS_"," D
. I XUSTACK(XUI)=+XUSTACK(XUI) S XUSUBS=XUSUBS_XUSTACK(XUI) ; VEN/SMH Fix psudo array bug.
. E S XUSUBS=XUSUBS_""""_XUSTACK(XUI)_""""
Q XUROOT_XUSUBS_")"
;
UES(X) ; Unescape JSON string
; copy segments from START to POS-2 (right before \)
; translate target character (which is at $F position)
N POS,Y,START
S POS=0,Y=""
F S START=POS+1 D Q:START>$L(X)
. S POS=$F(X,"\",START) ; find next position
. I 'POS S Y=Y_$E(X,START,$L(X)),POS=$L(X) Q
. ; otherwise handle escaped char
. N TGT
. S TGT=$E(X,POS),Y=Y_$E(X,START,POS-2)
. I TGT="u" S Y=Y_$C($$DEC^XLFUTL($E(X,POS+1,POS+4),16)),POS=POS+4 Q
. S Y=Y_$$REALCHAR(TGT)
Q Y
;
REALCHAR(C) ; Return actual character from escaped
I C="""" Q """"
I C="/" Q "/"
I C="\" Q "\"
I C="b" Q $C(8)
I C="f" Q $C(12)
I C="n" Q $C(10)
I C="r" Q $C(13)
I C="t" Q $C(9)
I C="u" ;case covered above in $$DEC^XLFUTL calls
;otherwise
I $L($G(XUERR)) D ERRX("ESC",C)
Q C
;
ERRX(ID,VAL) ; Set the appropriate error message
D ERRX^XLFJSON(ID,$G(VAL))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFJSOND 10828 printed Apr 09, 2024@21:19:11 Page 2
XLFJSOND ;SLC/KCM/TJB - Decode JSON ;26 Oct 2016
+1 ;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
DECODE(XUJSON,XUROOT,XUERR) ; Set JSON object into closed array ref XUROOT
+1 ;
DIRECT ; TAG for use by DECODE^XLFJSON
+1 ;
+2 ; Examples: D DECODE^XLFJSON("MYJSON","LOCALVAR","LOCALERR")
+3 ; D DECODE^XLFJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
+4 ;
+5 ; XUJSON: string/array containing serialized JSON object
+6 ; XUROOT: closed array reference for M representation of object
+7 ; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
+8 ;
+9 ; XUIDX: points to next character in JSON string to process
+10 ; XUSTACK: manages stack of subscripts
+11 ; XUPROP: true if next string is property name, otherwise treat as value
+12 ;
+13 ; limit document lines to 4000 characters
NEW XUMAX
SET XUMAX=4000
+14 SET XUERR=$GET(XUERR,"^TMP(""XLFJERR"",$J)")
+15 ; If a simple string is passed in, move it to an temp array (XUINPUT)
+16 ; so that the processing is consistently on an array.
+17 IF $DATA(@XUJSON)=1
NEW XUINPUT
SET XUINPUT(1)=@XUJSON
SET XUJSON="XUINPUT"
+18 ; make open array ref
SET XUROOT=$NAME(@XUROOT@("Z"))
SET XUROOT=$EXTRACT(XUROOT,1,$LENGTH(XUROOT)-4)
+19 NEW XULINE,XUIDX,XUSTACK,XUPROP,XUVAL,XUTYPE,XUERRORS
+20 SET XULINE=$ORDER(@XUJSON@(""))
SET XUIDX=1
SET XUSTACK=0
SET XUPROP=0
SET XUVAL=1
SET XUERRORS=0
+21 FOR
SET XUTYPE=$$NXTKN()
if XUTYPE=""
QUIT
Begin DoDot:1
+22 ; value was expected
IF XUVAL
SET XUVAL=0
IF ("}],:"[XUTYPE)
DO ERRX("NOV",XUTYPE)
QUIT
+23 IF XUTYPE="{"
SET XUSTACK=XUSTACK+1
SET XUSTACK(XUSTACK)=""
SET XUPROP=1
if XUSTACK>64
DO ERRX("STL{")
QUIT
+24 IF XUTYPE="}"
Begin DoDot:2
+25 ; Numeric and true only
IF +XUSTACK(XUSTACK)=XUSTACK(XUSTACK)
IF XUSTACK(XUSTACK)
DO ERRX("OBM")
+26 SET XUSTACK=XUSTACK-1
if XUSTACK<0
DO ERRX("SUF}")
End DoDot:2
QUIT
+27 IF XUTYPE="["
SET XUSTACK=XUSTACK+1
SET XUSTACK(XUSTACK)=1
if XUSTACK>64
DO ERRX("STL[")
QUIT
+28 IF XUTYPE="]"
if 'XUSTACK(XUSTACK)
DO ERRX("ARM")
SET XUSTACK=XUSTACK-1
if XUSTACK<0
DO ERRX("SUF]")
QUIT
+29 IF XUTYPE=","
Begin DoDot:2
+30 ; VEN/SMH - next in array
IF +XUSTACK(XUSTACK)=XUSTACK(XUSTACK)
IF XUSTACK(XUSTACK)
SET XUSTACK(XUSTACK)=XUSTACK(XUSTACK)+1
+31 ; or next property name
IF '$TEST
SET XUPROP=1
End DoDot:2
QUIT
+32 IF XUTYPE=":"
SET XUPROP=0
SET XUVAL=1
if '$LENGTH($GET(XUSTACK(XUSTACK)))
DO ERRX("MPN")
QUIT
+33 IF XUTYPE=""""
Begin DoDot:2
+34 IF XUPROP
SET XUSTACK(XUSTACK)=$$NAMPARS()
IF 1
+35 IF '$TEST
DO ADDSTR
End DoDot:2
QUIT
+36 SET XUTYPE=$TRANSLATE(XUTYPE,"TFN","tfn")
+37 IF XUTYPE="t"
DO SETBOOL("t")
QUIT
+38 IF XUTYPE="f"
DO SETBOOL("f")
QUIT
+39 IF XUTYPE="n"
DO SETBOOL("n")
QUIT
+40 ;S @$$CURNODE()=$$NUMPARS(XUTYPE) Q
IF "0123456789+-.eE"[XUTYPE
DO SETNUM(XUTYPE)
QUIT
+41 DO ERRX("TKN",XUTYPE)
End DoDot:1
IF XUERRORS
QUIT
+42 IF XUSTACK'=0
DO ERRX("SCT",XUSTACK)
+43 QUIT
NXTKN() ; Move the pointers to the beginning of the next token
+1 NEW XUDONE,XUEOF,XUTOKEN
+2 ; eat spaces & new lines until next visible char
SET XUDONE=0
SET XUEOF=0
FOR
Begin DoDot:1
+3 IF XUIDX>$LENGTH(@XUJSON@(XULINE))
SET XULINE=$ORDER(@XUJSON@(XULINE))
SET XUIDX=1
IF 'XULINE
SET XUEOF=1
QUIT
+4 IF $ASCII(@XUJSON@(XULINE),XUIDX)>32
SET XUDONE=1
QUIT
+5 SET XUIDX=XUIDX+1
End DoDot:1
if XUDONE!XUEOF
QUIT
+6 ; we're at the end of input
if XUEOF
QUIT ""
+7 SET XUTOKEN=$EXTRACT(@XUJSON@(XULINE),XUIDX)
SET XUIDX=XUIDX+1
+8 QUIT XUTOKEN
+9 ;
ADDSTR ; Add string value to current node, escaping text along the way
+1 ; Expects XULINE,XUIDX to reference that starting point of the index
+2 ; TODO: add a mechanism to specify names that should not be escaped
+3 ; just store as ":")= and ":",n)=
+4 ;
+5 ; Happy path -- we find the end quote in the same line
+6 NEW XUEND,XUX
+7 SET XUEND=$FIND(@XUJSON@(XULINE),"""",XUIDX)
+8 ;normal
IF XUEND
IF ($EXTRACT(@XUJSON@(XULINE),XUEND-2)'="\")
DO SETSTR
QUIT
+9 ;close quote preceded by escaped \
IF XUEND
IF $$ISCLOSEQ(XULINE)
DO SETSTR
QUIT
+10 ;
+11 ; Less happy path -- first quote wasn't close quote
+12 NEW XUDONE,XUTLINE
+13 ; XUTLINE for temporary increment of XULINE
SET XUDONE=0
SET XUTLINE=XULINE
+14 FOR
Begin DoDot:1
+15 ;if no quote on current line advance line, scan again
+16 IF 'XUEND
SET XUTLINE=XUTLINE+1
SET XUEND=1
IF '$DATA(@XUJSON@(XUTLINE))
DO ERRX("EIQ")
QUIT
+17 SET XUEND=$FIND(@XUJSON@(XUTLINE),"""",XUEND)
+18 ; continue on to next line if no quote found on this one
if 'XUEND
QUIT
+19 ; found quote position
IF (XUEND>2)
IF ($EXTRACT(@XUJSON@(XUTLINE),XUEND-2)'="\")
SET XUDONE=1
QUIT
+20 ; see if this is an escaped quote or closing quote
SET XUDONE=$$ISCLOSEQ(XUTLINE)
End DoDot:1
if XUDONE
QUIT
if XUERRORS
QUIT
+21 if XUERRORS
QUIT
+22 ; unescape from XUIDX to XUEND, using \-extension nodes as necessary
+23 DO UESEXT
+24 ; now we need to move XULINE and XUIDX to next parsing point
+25 SET XULINE=XUTLINE
SET XUIDX=XUEND
+26 QUIT
SETSTR ; Set simple string value from within same line
+1 ; expects XUJSON, XULINE, XUINX, XUEND
+2 NEW XUX
+3 SET XUX=$EXTRACT(@XUJSON@(XULINE),XUIDX,XUEND-2)
SET XUIDX=XUEND
+4 SET @$$CURNODE()=$$UES(XUX)
+5 ; "\s" node indicates value is really a string in case value
+6 ; collates as numeric or equals boolean keywords
+7 IF XUX']]$CHAR(1)
SET @$$CURNODE()@("\s")=""
+8 IF XUX="true"!(XUX="false")!(XUX="null")
SET @$$CURNODE()@("\s")=""
+9 IF XUIDX>$LENGTH(@XUJSON@(XULINE))
SET XULINE=XULINE+1
SET XUIDX=1
+10 QUIT
UESEXT ; unescape from XULINE,XUIDX to XUTLINE,XUEND & extend (\) if necessary
+1 ; expects XULINE,XUIDX,XUTLINE,XUEND
+2 NEW XUI,XUY,XUSTART,XUSTOP,XUDONE,XUBUF,XUNODE,XUMORE,XUTO
+3 SET XUNODE=$$CURNODE()
SET XUBUF=""
SET XUMORE=0
SET XUSTOP=XUEND-2
+4 SET XUI=XUIDX
SET XUY=XULINE
SET XUDONE=0
+5 FOR
Begin DoDot:1
+6 SET XUSTART=XUI
SET XUI=$FIND(@XUJSON@(XUY),"\",XUI)
+7 ; if we are on the last line, don't extract past XUSTOP
+8 IF (XUY=XUTLINE)
SET XUTO=$SELECT('XUI:XUSTOP,XUI>XUSTOP:XUSTOP,1:XUI-2)
IF 1
+9 IF '$TEST
SET XUTO=$SELECT('XUI:99999,1:XUI-2)
+10 DO ADDBUF($EXTRACT(@XUJSON@(XUY),XUSTART,XUTO))
+11 ; now past close quote
IF (XUY'<XUTLINE)
IF (('XUI)!(XUI>XUSTOP))
SET XUDONE=1
QUIT
+12 ; nothing escaped, go to next line
IF 'XUI
SET XUY=XUY+1
SET XUI=1
QUIT
+13 IF XUI>$LENGTH(@XUJSON@(XUY))
SET XUY=XUY+1
SET XUI=1
IF '$DATA(@XUJSON@(XUY))
DO ERRX("EIU")
+14 NEW XUTGT
SET XUTGT=$EXTRACT(@XUJSON@(XUY),XUI)
+15 IF XUTGT="u"
Begin DoDot:2
+16 NEW XUTGTC
SET XUTGTC=$EXTRACT(@XUJSON@(XUY),XUI+1,XUI+4)
SET XUI=XUI+4
+17 IF $LENGTH(XUTGTC)<4
SET XUY=XUY+1
SET XUI=4-$LENGTH(XUTGTC)
SET XUTGTC=XUTGTC_$EXTRACT(@XUJSON@(XUY),1,XUI)
+18 DO ADDBUF($CHAR($$DEC^XLFUTL(XUTGTC,16)))
End DoDot:2
IF 1
+19 IF '$TEST
DO ADDBUF($$REALCHAR(XUTGT))
+20 SET XUI=XUI+1
+21 ; XUI incremented past stop
IF (XUY'<XUTLINE)
IF (XUI>XUSTOP)
SET XUDONE=1
End DoDot:1
if XUDONE
QUIT
if XUERRORS
QUIT
+22 if XUERRORS
QUIT
+23 DO SAVEBUF
+24 QUIT
ADDBUF(XUX) ; add buffer of characters to destination
+1 ; expects XUBUF,XUMAX,XUNODE,XUMORE to be defined
+2 ; used directly by ADDSTR
+3 IF $LENGTH(XUX)+$LENGTH(XUBUF)>XUMAX
DO SAVEBUF
+4 SET XUBUF=XUBUF_XUX
+5 QUIT
SAVEBUF ; write out buffer to destination
+1 ; expects XUBUF,XUMAX,XUNODE,XUMORE to be defined
+2 ; used directly by ADDSTR,ADDBUF
+3 IF XUMORE
SET @XUNODE@("\",XUMORE)=XUBUF
+4 IF 'XUMORE
SET @XUNODE=XUBUF
IF $LENGTH(XUBUF)<19
IF +$EXTRACT(XUBUF,1,18)
SET @XUNODE@("\s")=""
+5 SET XUMORE=XUMORE+1
SET XUBUF=""
+6 QUIT
ISCLOSEQ(XUBLINE) ; return true if this is a closing, rather than escaped, quote
+1 ; expects
+2 ; XUJSON: lines of the JSON encoded string
+3 ; XUIDX: points to 1st character of the segment
+4 ; XULINE: points to the line in which the segment starts
+5 ; XUEND: points to 1st character after the " (may be past the end of the line)
+6 ; used directly by ADDSTR
+7 NEW XUBS,XUBIDX,XUBDONE
+8 ; XUBIDX starts at 1st character before quote
SET XUBS=0
SET XUBIDX=XUEND-2
SET XUBDONE=0
+9 ; count the backslashes preceding the quote (odd number means the quote was escaped)
+10 FOR
Begin DoDot:1
+11 ; when XUBIDX<1 go back a line
IF XUBIDX<1
Begin DoDot:2
+12 SET XUBLINE=XUBLINE-1
IF XUBLINE<XULINE
DO ERRX("RSB")
QUIT
+13 SET XUBIDX=$LENGTH(@XUJSON@(XUBLINE))
End DoDot:2
QUIT
+14 IF $EXTRACT(@XUJSON@(XUBLINE),XUBIDX)'="\"
SET XUBDONE=1
QUIT
+15 SET XUBS=XUBS+1
SET XUBIDX=XUBIDX-1
End DoDot:1
if XUBDONE!XUERRORS
QUIT
+16 ; XUBS is even if this is a close quote
QUIT XUBS#2=0
+17 ;
NAMPARS() ; Return parsed name, advancing index past the close quote
+1 ; -- This assumes no embedded quotes are in the name itself --
+2 NEW XUEND,XUDONE,XUNAME
+3 SET XUDONE=0
SET XUNAME=""
+4 FOR
Begin DoDot:1
+5 SET XUEND=$FIND(@XUJSON@(XULINE),"""",XUIDX)
+6 IF XUEND
SET XUNAME=XUNAME_$EXTRACT(@XUJSON@(XULINE),XUIDX,XUEND-2)
SET XUIDX=XUEND
SET XUDONE=1
+7 IF 'XUEND
SET XUNAME=XUNAME_$EXTRACT(@XUJSON@(XULINE),XUIDX,$LENGTH(@XUJSON@(XULINE)))
+8 IF 'XUEND!(XUEND>$LENGTH(@XUJSON@(XULINE)))
SET XULINE=XULINE+1
SET XUIDX=1
IF '$DATA(@XUJSON@(XULINE))
DO ERRX("ORN")
End DoDot:1
if XUDONE
QUIT
if XUERRORS
QUIT
+9 ; prepend quote if label collates as numeric -- assumes no quotes in label
+10 IF XUNAME']]$CHAR(1)
SET XUNAME=""""""_XUNAME
+11 QUIT XUNAME
+12 ;
SETNUM(XUDIGIT) ; Set numeric along with any necessary modifier
+1 NEW XUX
+2 SET XUX=$$NUMPARS(XUDIGIT)
+3 SET @$$CURNODE()=+XUX
+4 ; if numeric is exponent, "0.nnn" or "-0.nnn" store original string
+5 IF +XUX'=XUX
SET @$$CURNODE()@("\n")=XUX
+6 QUIT
NUMPARS(XUDIGIT) ; Return parsed number, advancing index past end of number
+1 ; XUIDX intially references the second digit
+2 NEW XUDONE,XUNUM
+3 SET XUDONE=0
SET XUNUM=XUDIGIT
+4 FOR
Begin DoDot:1
+5 IF '("0123456789+-.eE"[$EXTRACT(@XUJSON@(XULINE),XUIDX))
SET XUDONE=1
QUIT
+6 SET XUNUM=XUNUM_$EXTRACT(@XUJSON@(XULINE),XUIDX)
+7 SET XUIDX=XUIDX+1
IF XUIDX>$LENGTH(@XUJSON@(XULINE))
SET XULINE=XULINE+1
SET XUIDX=1
IF '$DATA(@XUJSON@(XULINE))
DO ERRX("OR#")
End DoDot:1
if XUDONE
QUIT
if XUERRORS
QUIT
+8 QUIT XUNUM
+9 ;
SETBOOL(XULTR) ; Parse and set boolean value, advancing index past end of value
+1 NEW XUDONE,XUBOOL,XUX
+2 SET XUDONE=0
SET XUBOOL=XULTR
+3 FOR
Begin DoDot:1
+4 SET XUX=$TRANSLATE($EXTRACT(@XUJSON@(XULINE),XUIDX),"TRUEFALSN","truefalsn")
+5 IF '("truefalsn"[XUX)
SET XUDONE=1
QUIT
+6 SET XUBOOL=XUBOOL_XUX
+7 SET XUIDX=XUIDX+1
IF XUIDX>$LENGTH(@XUJSON@(XULINE))
SET XULINE=XULINE+1
SET XUIDX=1
IF '$DATA(@XUJSON@(XULINE))
DO ERRX("ORB")
End DoDot:1
if XUDONE
QUIT
if XUERRORS
QUIT
+8 IF XULTR="t"
IF (XUBOOL'="true")
DO ERRX("EXT",XUTYPE)
+9 IF XULTR="f"
IF (XUBOOL'="false")
DO ERRX("EXF",XUTYPE)
+10 IF XULTR="n"
IF (XUBOOL'="null")
DO ERRX("EXN",XUTYPE)
+11 SET @$$CURNODE()=XUBOOL
+12 QUIT
+13 ;
OSETBOOL(XUX) ; set a value and increment XUIDX
+1 SET @$$CURNODE()=XUX
+2 SET XUIDX=XUIDX+$LENGTH(XUX)-1
+3 ; in case XUIDX moves to next line
NEW XUDIFF
SET XUDIFF=XUIDX-$LENGTH(@XUJSON@(XULINE))
+4 IF XUDIFF>0
SET XULINE=XULINE+1
SET XUIDX=XUDIFF
IF '$DATA(@XUJSON@(XULINE))
DO ERRX("ORB")
+5 QUIT
CURNODE() ; Return a global/local variable name based on XUSTACK
+1 ; Expects XUSTACK to be defined already
+2 NEW XUI,XUSUBS
+3 SET XUSUBS=""
+4 FOR XUI=1:1:XUSTACK
if XUI>1
SET XUSUBS=XUSUBS_","
Begin DoDot:1
+5 ; VEN/SMH Fix psudo array bug.
IF XUSTACK(XUI)=+XUSTACK(XUI)
SET XUSUBS=XUSUBS_XUSTACK(XUI)
+6 IF '$TEST
SET XUSUBS=XUSUBS_""""_XUSTACK(XUI)_""""
End DoDot:1
+7 QUIT XUROOT_XUSUBS_")"
+8 ;
UES(X) ; Unescape JSON string
+1 ; copy segments from START to POS-2 (right before \)
+2 ; translate target character (which is at $F position)
+3 NEW POS,Y,START
+4 SET POS=0
SET Y=""
+5 FOR
SET START=POS+1
Begin DoDot:1
+6 ; find next position
SET POS=$FIND(X,"\",START)
+7 IF 'POS
SET Y=Y_$EXTRACT(X,START,$LENGTH(X))
SET POS=$LENGTH(X)
QUIT
+8 ; otherwise handle escaped char
+9 NEW TGT
+10 SET TGT=$EXTRACT(X,POS)
SET Y=Y_$EXTRACT(X,START,POS-2)
+11 IF TGT="u"
SET Y=Y_$CHAR($$DEC^XLFUTL($EXTRACT(X,POS+1,POS+4),16))
SET POS=POS+4
QUIT
+12 SET Y=Y_$$REALCHAR(TGT)
End DoDot:1
if START>$LENGTH(X)
QUIT
+13 QUIT Y
+14 ;
REALCHAR(C) ; Return actual character from escaped
+1 IF C=""""
QUIT """"
+2 IF C="/"
QUIT "/"
+3 IF C="\"
QUIT "\"
+4 IF C="b"
QUIT $CHAR(8)
+5 IF C="f"
QUIT $CHAR(12)
+6 IF C="n"
QUIT $CHAR(10)
+7 IF C="r"
QUIT $CHAR(13)
+8 IF C="t"
QUIT $CHAR(9)
+9 ;case covered above in $$DEC^XLFUTL calls
IF C="u"
+10 ;otherwise
+11 IF $LENGTH($GET(XUERR))
DO ERRX("ESC",C)
+12 QUIT C
+13 ;
ERRX(ID,VAL) ; Set the appropriate error message
+1 DO ERRX^XLFJSON(ID,$GET(VAL))
+2 QUIT
