- 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 Feb 18, 2025@23:29:10 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