| 1 | ZWR1 ;DUMP GLOBALS IN ZWR FORMAT ; RCR Version ; Compiled November 18, 2007 01:33:38
|
|---|
| 2 | ;dump Cache globals to a file in GTM's ZWR format
|
|---|
| 3 | ;mlp 18nov01 New routine
|
|---|
| 4 | ;mlp 07jan02 Update to encode some chars > 127; limit $C args to 256.
|
|---|
| 5 | ; Use LF instead of ! to end lines.
|
|---|
| 6 | ;wb 20Sep02 save each global to a separate file in "/data/" %ZWRSEP
|
|---|
| 7 | ;WB 19OCT03 INTEGRATE $$EXIST FROM EXTERNAL ROUTINE
|
|---|
| 8 | ;wb 04Jan04 Add output directory query
|
|---|
| 9 | ;NEA 9-13-06 Ask if you want to exclude lower case globals
|
|---|
| 10 | ;JEG fixed the GSET problem 6-16-07`
|
|---|
| 11 | ;RCR Allow pickup of ^%ZIS 3070815
|
|---|
| 12 | ;mlp 18nov07 %SYS.GSET uses ^CacheTempJ not ^UTILITY, and other clean-ups.
|
|---|
| 13 | W !!,"DUMPS GLOBALS IN ZWR FORMAT",!!
|
|---|
| 14 | ; D OUT^%IS Q:$G(IO)="" ;request output dev
|
|---|
| 15 | r !,"Output directory? ",ZOUTDIR Q:ZOUTDIR=""
|
|---|
| 16 | s:"\/"'[$E(ZOUTDIR,$L(ZOUTDIR)) ZOUTDIR=ZOUTDIR_"\"
|
|---|
| 17 | D ^%SYS.GSET Q:$G(%G)<1 ;request globals to dump (Cache 5.1+)
|
|---|
| 18 | ;
|
|---|
| 19 | ; Should globals with lower case in their names be excluded?
|
|---|
| 20 | NEW GLOYN
|
|---|
| 21 | ASKLC R !!, "Exclude globals with lower case letters in the name? (N) ",GLOYN
|
|---|
| 22 | I GLOYN="" S GLOYN="N" W "N"
|
|---|
| 23 | I GLOYN?1"?".E D G ASKLC
|
|---|
| 24 | . W !,"Cache specific globals may contain lower case letters.",!
|
|---|
| 25 | . W "You may choose to exclude them if you are exporting the globals ",!
|
|---|
| 26 | . W "to use with another M implementation such as GT.M."
|
|---|
| 27 | I "YyNn"'[$E(GLOYN) W " Answer Y, N or ?" G ASKLC
|
|---|
| 28 | S CASEFLTR=(GLOYN?1"Y".E)!(GLOYN?1"y".E)
|
|---|
| 29 | ;
|
|---|
| 30 | ASK R !!,"Comment ? ",COM,! I COM?1"?".E D G ASK
|
|---|
| 31 | . W "Enter a comment to save with the file. ",!
|
|---|
| 32 | S H=$H,LF=$C(10),QT="""",C255=$C(255),SKIP=$T(SKIP)
|
|---|
| 33 | S GN=""
|
|---|
| 34 | F S GN=$O(^CacheTempJ($J,GN)) Q:GN="" D
|
|---|
| 35 | . I CASEFLTR,GN?.E1L.E Quit
|
|---|
| 36 | . S GNN="^"_GN
|
|---|
| 37 | . s IOP=ZOUTDIR_GN_".zwr",IOPAR="WNS" ;;JEG; Add Path
|
|---|
| 38 | . I SKIP[(";"_GNN_";") w "Skipping ",IOP," - in exclusion set",! Q
|
|---|
| 39 | . i $$exist(IOP) w "Skipping ",IOP," - already exists",! Q
|
|---|
| 40 | . w "Opening ",IOP,!
|
|---|
| 41 | . S IO=IOP O IO:("WNS"):10 E S IO="" ;;JEG;Cache Open
|
|---|
| 42 | . I $G(IO)="" u $p w "error opening "_IOP,! r "Waiting for user...",junk q
|
|---|
| 43 | . ;d OUT^%IS i $G(IO)="" u $p w "error opening "_IOP,! r "Waiting for user...",junk q ;;JEG;Disabled
|
|---|
| 44 | . U IO
|
|---|
| 45 | . W COM,LF
|
|---|
| 46 | . W "Cache "_$TR($ZD(H,2)," ","-")_" "_$ZT($P(H,",",2))_" ZWR",LF
|
|---|
| 47 | . s cnt=0
|
|---|
| 48 | . D WALK(GNN)
|
|---|
| 49 | . C IO U $P
|
|---|
| 50 | W !,"Done.",!
|
|---|
| 51 | Q
|
|---|
| 52 | ;
|
|---|
| 53 | WALK(G) ;walk through global G, convert subscripts and values as necessary, dump out
|
|---|
| 54 | Q:'$D(@G) Q:G["(" ; chk if @G defined, and must be a top-level name
|
|---|
| 55 | I $D(@G)#2 D ; handle case where top-level node has data
|
|---|
| 56 | . S NAME=$NA(@G)
|
|---|
| 57 | . S VAL=$$CGV(@G)
|
|---|
| 58 | . W NAME_"="_VAL,LF
|
|---|
| 59 | F S G=$Q(@G) Q:G="" D ;handle rest of global G
|
|---|
| 60 | . S NAME=$NA(@G)
|
|---|
| 61 | . S NAME=$$RCC(NAME) D
|
|---|
| 62 | . . N P ;Remove initial ""_ or final _""
|
|---|
| 63 | . . S P=$F(NAME,"(") I P,$E(NAME,P,P+2)="""""_" S $E(NAME,P,P+2)=""
|
|---|
| 64 | . . S P=$L(NAME) S:$E(NAME,P-3,P-1)="_""""" $E(NAME,P-3,P-1)=""
|
|---|
| 65 | . S VAL=$$CGV(@G)
|
|---|
| 66 | . W NAME_"="_VAL,LF
|
|---|
| 67 | . s cnt=cnt+1
|
|---|
| 68 | . i cnt#10000=0 u $p w "." u IO
|
|---|
| 69 | Q
|
|---|
| 70 | ;
|
|---|
| 71 | RCC(NA) ;Replace control chars in NA with $C( ). Returns encoded string.
|
|---|
| 72 | Q:'$$CCC(NA) NA ;No embedded ctrl chars
|
|---|
| 73 | N OUT S OUT="" ;holds output name
|
|---|
| 74 | N CC S CC=0 ;count ctrl chars in $C(
|
|---|
| 75 | N C ;temp hold each char
|
|---|
| 76 | F I=1:1:$L(NA) S C=$E(NA,I) D ;for each char C in NA
|
|---|
| 77 | . I C'?1C,C'=C255 D S OUT=OUT_C Q ;not a ctrl char
|
|---|
| 78 | . . I CC S OUT=OUT_")_""",CC=0 ;close up $C(... if one is open
|
|---|
| 79 | . I CC D
|
|---|
| 80 | . . I CC=256 S OUT=OUT_")_$C("_$A(C),CC=0 ;max args in one $C(
|
|---|
| 81 | . . E S OUT=OUT_","_$A(C) ;add next ctrl char to $C(
|
|---|
| 82 | . E S OUT=OUT_"""_$C("_$A(C)
|
|---|
| 83 | . S CC=CC+1
|
|---|
| 84 | . Q
|
|---|
| 85 | Q OUT
|
|---|
| 86 | ;
|
|---|
| 87 | CGV(V) ;Convert Global Value.
|
|---|
| 88 | ;If no encoding required, then return as quoted string.
|
|---|
| 89 | ;Otherwise, return as an expression with $C()'s and strings.
|
|---|
| 90 | I $F(V,QT) D ;chk if V contains any Quotes
|
|---|
| 91 | . S P=0 ;position pointer into V
|
|---|
| 92 | . F S P=$F(V,QT,P) Q:'P D ;find next "
|
|---|
| 93 | . . S $E(V,P-1)=QT_QT ;double each "
|
|---|
| 94 | . . S P=P+1 ;skip over new "
|
|---|
| 95 | I $$CCC(V) D Q V
|
|---|
| 96 | . S V=$$RCC(QT_V_QT)
|
|---|
| 97 | . S:$E(V,1,3)="""""_" $E(V,1,3)=""
|
|---|
| 98 | . S L=$L(V) S:$E(V,L-2,L)="_""""" $E(V,L-2,L)=""
|
|---|
| 99 | Q QT_V_QT
|
|---|
| 100 | ;
|
|---|
| 101 | CCC(S) ;test if S Contains a Control Character or $C(255).
|
|---|
| 102 | Q:S?.E1C.E 1
|
|---|
| 103 | Q:$F(S,$C(255)) 1
|
|---|
| 104 | Q 0
|
|---|
| 105 | SKIP ;;^CacheTemp;^ROUTINE;^mtemp;^mtemp0;^mtemp1;^oddCOM;^oddDEF;^oddMAC;^oddMAP;^oddPROC;^rINC;^rOBJ;^%utility;^%UTILITY;^TMP;^XUTL;^UTILITY;
|
|---|
| 106 | exist(fn)
|
|---|
| 107 | n %
|
|---|
| 108 | s %=$zu(140,4,fn)
|
|---|
| 109 | q (%=0)
|
|---|
| 110 | ;
|
|---|
