Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XLFJSOND

XLFJSOND.m

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