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

VPRJSOND.m

Go to the documentation of this file. 
  1. VPRJSOND ;SLC/KCM -- Decode JSON
  1.  ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
  1.  ;
  1. DECODE(VVJSON,VVROOT,VVERR) ; Set JSON object into closed array ref VVROOT
  1.  ;
  1. DIRECT ; TAG for use by DECODE^VPRJSON
  1.  ;
  1.  ; Examples: D DECODE^VPRJSON("MYJSON","LOCALVAR","LOCALERR")
  1.  ;           D DECODE^VPRJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
  1.  ;
  1.  ; VVJSON: string/array containing serialized JSON object
  1.  ; VVROOT: closed array reference for M representation of object
  1.  ;  VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
  1.  ;
  1.  ;   VVIDX: points to next character in JSON string to process
  1.  ; VVSTACK: manages stack of subscripts
  1.  ;  VVPROP: true if next string is property name, otherwise treat as value
  1.  ;
  1.  N VVMAX S VVMAX=4000 ; limit document lines to 4000 characters
  1.  S VVERR=$G(VVERR,"^TMP(""VPRJERR"",$J)")
  1.  ; If a simple string is passed in, move it to an temp array (VVINPUT)
  1.  ; so that the processing is consistently on an array.
  1.  I $D(@VVJSON)=1 N VVINPUT S VVINPUT(1)=@VVJSON,VVJSON="VVINPUT"
  1.  S VVROOT=$NA(@VVROOT@("Z")),VVROOT=$E(VVROOT,1,$L(VVROOT)-4) ; make open array ref
  1.  N VVLINE,VVIDX,VVSTACK,VVPROP,VVTYPE,VVERRORS
  1.  S VVLINE=$O(@VVJSON@("")),VVIDX=1,VVSTACK=0,VVPROP=0,VVERRORS=0
  1.  F  S VVTYPE=$$NXTKN() Q:VVTYPE=""  D  I VVERRORS Q
  1.  . I VVTYPE="{" S VVSTACK=VVSTACK+1,VVSTACK(VVSTACK)="",VVPROP=1 D:VVSTACK>64 ERRX("STL{") Q
  1.  . I VVTYPE="}" D:VVSTACK(VVSTACK) ERRX("OBM") S VVSTACK=VVSTACK-1 D:VVSTACK<0 ERRX("SUF}") Q
  1.  . I VVTYPE="[" S VVSTACK=VVSTACK+1,VVSTACK(VVSTACK)=1 D:VVSTACK>64 ERRX("STL[") Q
  1.  . I VVTYPE="]" D:'VVSTACK(VVSTACK) ERRX("ARM") S VVSTACK=VVSTACK-1 D:VVSTACK<0 ERRX("SUF]") Q
  1.  . I VVTYPE="," D  Q
  1.  . . I VVSTACK(VVSTACK) S VVSTACK(VVSTACK)=VVSTACK(VVSTACK)+1  ; next in array
  1.  . . E  S VVPROP=1                                   ; or next property name
  1.  . I VVTYPE=":" S VVPROP=0 D:'$L($G(VVSTACK(VVSTACK))) ERRX("MPN") Q
  1.  . I VVTYPE="""" D  Q
  1.  . . I VVPROP S VVSTACK(VVSTACK)=$$NAMPARS() I 1
  1.  . . E  D ADDSTR
  1.  . S VVTYPE=$TR(VVTYPE,"TFN","tfn")
  1.  . I VVTYPE="t" D SETBOOL("t") Q
  1.  . I VVTYPE="f" D SETBOOL("f") Q
  1.  . I VVTYPE="n" D SETBOOL("n") Q
  1.  . I "0123456789+-.eE"[VVTYPE S @$$CURNODE()=$$NUMPARS(VVTYPE) Q
  1.  . D ERRX("TKN",VVTYPE)
  1.  I VVSTACK'=0 D ERRX("SCT",VVSTACK)
  1.  Q
  1. NXTKN() ; Move the pointers to the beginning of the next token
  1.  N VVDONE,VVEOF,VVTOKEN
  1.  S VVDONE=0,VVEOF=0 F  D  Q:VVDONE!VVEOF  ; eat spaces & new lines until next visible char
  1.  . I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=$O(@VVJSON@(VVLINE)),VVIDX=1 I 'VVLINE S VVEOF=1 Q
  1.  . I $A(@VVJSON@(VVLINE),VVIDX)>32 S VVDONE=1 Q
  1.  . S VVIDX=VVIDX+1
  1.  Q:VVEOF ""  ; we're at the end of input
  1.  S VVTOKEN=$E(@VVJSON@(VVLINE),VVIDX),VVIDX=VVIDX+1
  1.  Q VVTOKEN
  1.  ;
  1. ADDSTR ; Add string value to current node, escaping text along the way
  1.  ; Expects VVLINE,VVIDX 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 VVEND,VVX
  1.  S VVEND=$F(@VVJSON@(VVLINE),"""",VVIDX)
  1.  I VVEND,($E(@VVJSON@(VVLINE),VVEND-2)'="\") D SETSTR  QUIT  ;normal
  1.  I VVEND,$$ISCLOSEQ(VVLINE) D SETSTR QUIT  ;close quote preceded by escaped \
  1.  ;
  1.  ; Less happy path -- first quote wasn't close quote
  1.  N VVDONE,VVTLINE
  1.  S VVDONE=0,VVTLINE=VVLINE ; VVTLINE for temporary increment of VVLINE
  1.  F  D  Q:VVDONE  Q:VVERRORS
  1.  . ;if no quote on current line advance line, scan again
  1.  . I 'VVEND S VVTLINE=VVTLINE+1,VVEND=1 I '$D(@VVJSON@(VVTLINE)) D ERRX("EIQ") Q
  1.  . S VVEND=$F(@VVJSON@(VVTLINE),"""",VVEND)
  1.  . Q:'VVEND  ; continue on to next line if no quote found on this one
  1.  . I (VVEND>2),($E(@VVJSON@(VVTLINE),VVEND-2)'="\") S VVDONE=1 Q  ; found quote position
  1.  . S VVDONE=$$ISCLOSEQ(VVTLINE) ; see if this is an escaped quote or closing quote
  1.  Q:VVERRORS
  1.  ; unescape from VVIDX to VVEND, using \-extension nodes as necessary
  1.  D UESEXT
  1.  ; now we need to move VVLINE and VVIDX to next parsing point
  1.  S VVLINE=VVTLINE,VVIDX=VVEND
  1.  Q
  1. SETSTR ; Set simple string value from within same line
  1.  ; expects VVJSON, VVLINE, VVINX, VVEND
  1.  N VVX
  1.  S VVX=$E(@VVJSON@(VVLINE),VVIDX,VVEND-2),VVIDX=VVEND
  1.  S @$$CURNODE()=$$UES(VVX)
  1.  I (+VVX=VVX)!($E(VVX,1,2)="0.")!($E(VVX,1,3)="-0.") S @$$CURNODE()@("\s")=""
  1.  I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1
  1.  Q
  1. UESEXT ; unescape from VVLINE,VVIDX to VVTLINE,VVEND & extend (\) if necessary
  1.  ; expects VVLINE,VVIDX,VVTLINE,VVEND
  1.  N VVI,VVY,VVSTART,VVSTOP,VVDONE,VVBUF,VVNODE,VVMORE,VVTO
  1.  S VVNODE=$$CURNODE(),VVBUF="",VVMORE=0,VVSTOP=VVEND-2
  1.  S VVI=VVIDX,VVY=VVLINE,VVDONE=0
  1.  F  D  Q:VVDONE  Q:VVERRORS
  1.  . S VVSTART=VVI,VVI=$F(@VVJSON@(VVY),"\",VVI)
  1.  . ; if we are on the last line, don't extract past VVSTOP
  1.  . I (VVY=VVTLINE) S VVTO=$S('VVI:VVSTOP,VVI>VVSTOP:VVSTOP,1:VVI-2) I 1
  1.  . E  S VVTO=$S('VVI:99999,1:VVI-2)
  1.  . D ADDBUF($E(@VVJSON@(VVY),VVSTART,VVTO))
  1.  . I (VVY'<VVTLINE),(('VVI)!(VVI>VVSTOP)) S VVDONE=1 QUIT  ; now past close quote
  1.  . I 'VVI S VVY=VVY+1,VVI=1 QUIT  ; nothing escaped, go to next line
  1.  . I VVI>$L(@VVJSON@(VVY)) S VVY=VVY+1,VVI=1 I '$D(@VVJSON@(VVY)) D ERRX("EIU")
  1.  . N VVTGT S VVTGT=$E(@VVJSON@(VVY),VVI)
  1.  . I VVTGT="u" D  I 1
  1.  . . N VVTGTC S VVTGTC=$E(@VVJSON@(VVY),VVI+1,VVI+4),VVI=VVI+4
  1.  . . I $L(VVTGTC)<4 S VVY=VVY+1,VVI=4-$L(VVTGTC),VVTGTC=VVTGTC_$E(@VVJSON@(VVY),1,VVI)
  1.  . . D ADDBUF($C($$DEC^XLFUTL(VVTGTC,16)))
  1.  . E  D ADDBUF($$REALCHAR(VVTGT))
  1.  . S VVI=VVI+1
  1.  . I (VVY'<VVTLINE),(VVI>VVSTOP) S VVDONE=1 ; VVI incremented past stop
  1.  Q:VVERRORS
  1.  D SAVEBUF
  1.  Q
  1. ADDBUF(VVX) ; add buffer of characters to destination
  1.  ; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
  1.  ; used directly by ADDSTR
  1.  I $L(VVX)+$L(VVBUF)>VVMAX D SAVEBUF
  1.  S VVBUF=VVBUF_VVX
  1.  Q
  1. SAVEBUF ; write out buffer to destination
  1.  ; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
  1.  ; used directly by ADDSTR,ADDBUF
  1.  I VVMORE S @VVNODE@("\",VVMORE)=VVBUF
  1.  I 'VVMORE S @VVNODE=VVBUF I $L(VVBUF)<19,+$E(VVBUF,1,18) S @VVNODE@("\s")=""
  1.  S VVMORE=VVMORE+1,VVBUF=""
  1.  Q
  1. ISCLOSEQ(VVBLINE) ; return true if this is a closing, rather than escaped, quote
  1.  ; expects
  1.  ;   VVJSON: lines of the JSON encoded string
  1.  ;    VVIDX: points to 1st character of the segment
  1.  ;   VVLINE: points to the line in which the segment starts
  1.  ;    VVEND: points to 1st character after the " (may be past the end of the line)
  1.  ; used directly by ADDSTR
  1.  N VVBS,VVBIDX,VVBDONE
  1.  S VVBS=0,VVBIDX=VVEND-2,VVBDONE=0 ; VVBIDX starts at 1st character before quote
  1.  ; count the backslashes preceding the quote (odd number means the quote was escaped)
  1.  F  D  Q:VVBDONE!VVERRORS
  1.  . I VVBIDX<1 D  Q  ; when VVBIDX<1 go back a line
  1.  . . S VVBLINE=VVBLINE-1 I VVBLINE<VVLINE D ERRX("RSB") Q
  1.  . . S VVBIDX=$L(@VVJSON@(VVBLINE))
  1.  . I $E(@VVJSON@(VVBLINE),VVBIDX)'="\" S VVBDONE=1 Q
  1.  . S VVBS=VVBS+1,VVBIDX=VVBIDX-1
  1.  Q VVBS#2=0  ; VVBS 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 VVEND,VVDONE,VVNAME
  1.  S VVDONE=0,VVNAME=""
  1.  F  D  Q:VVDONE  Q:VVERRORS
  1.  . S VVEND=$F(@VVJSON@(VVLINE),"""",VVIDX)
  1.  . I VVEND S VVNAME=VVNAME_$E(@VVJSON@(VVLINE),VVIDX,VVEND-2),VVIDX=VVEND,VVDONE=1
  1.  . I 'VVEND S VVNAME=VVNAME_$E(@VVJSON@(VVLINE),VVIDX,$L(@VVJSON@(VVLINE)))
  1.  . I 'VVEND!(VVEND>$L(@VVJSON@(VVLINE))) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("ORN")
  1.  Q VVNAME
  1.  ;
  1. NUMPARS(VVDIGIT) ; Return parsed number, advancing index past the end of the number
  1.  ; VVIDX intially references the second digit
  1.  N VVDONE,VVNUM
  1.  S VVDONE=0,VVNUM=VVDIGIT
  1.  F  D  Q:VVDONE  Q:VVERRORS
  1.  . I '("0123456789+-.eE"[$E(@VVJSON@(VVLINE),VVIDX)) S VVDONE=1 Q
  1.  . S VVNUM=VVNUM_$E(@VVJSON@(VVLINE),VVIDX)
  1.  . S VVIDX=VVIDX+1 I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("OR#")
  1.  Q VVNUM
  1.  ;
  1. SETBOOL(VVLTR) ; Return parsed value, advancing index past the end of the value
  1.  N VVDONE,VVBOOL,VVX
  1.  S VVDONE=0,VVBOOL=VVLTR
  1.  F  D  Q:VVDONE  Q:VVERRORS
  1.  . S VVX=$TR($E(@VVJSON@(VVLINE),VVIDX),"TRUEFALSN","truefalsn")
  1.  . I '("truefalsn"[VVX) S VVDONE=1 Q
  1.  . S VVBOOL=VVBOOL_VVX
  1.  . S VVIDX=VVIDX+1 I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("ORB")
  1.  I VVLTR="t",(VVBOOL'="true") D ERRX("EXT",VVTYPE)
  1.  I VVLTR="f",(VVBOOL'="false") D ERRX("EXF",VVTYPE)
  1.  I VVLTR="n",(VVBOOL'="null") D ERRX("EXN",VVTYPE)
  1.  S @$$CURNODE()=VVBOOL
  1.  Q
  1.  ;
  1. OSETBOOL(VVX) ; set a value and increment VVIDX
  1.  S @$$CURNODE()=VVX
  1.  S VVIDX=VVIDX+$L(VVX)-1
  1.  N VVDIFF S VVDIFF=VVIDX-$L(@VVJSON@(VVLINE))  ; in case VVIDX moves to next line
  1.  I VVDIFF>0 S VVLINE=VVLINE+1,VVIDX=VVDIFF I '$D(@VVJSON@(VVLINE)) D ERRX("ORB")
  1.  Q
  1. CURNODE() ; Return a global/local variable name based on VVSTACK
  1.  ; Expects VVSTACK to be defined already
  1.  N VVI,VVSUBS
  1.  S VVSUBS=""
  1.  F VVI=1:1:VVSTACK S:VVI>1 VVSUBS=VVSUBS_"," D
  1.  . I VVSTACK(VVI) S VVSUBS=VVSUBS_VVSTACK(VVI)
  1.  . E  S VVSUBS=VVSUBS_""""_VVSTACK(VVI)_""""
  1.  Q VVROOT_VVSUBS_")"
  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(VVERR)) D ERRX("ESC",C)
  1.  Q C
  1.  ;
  1. ERRX(ID,VAL) ; Set the appropriate error message
  1.  D ERRX^VPRJSON(ID,$G(VAL))
  1.  Q