source: WorldVistAEHR/trunk/r/ZZOTHER/ZWR1.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1ZWR1 ;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
21ASKLC 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 ;
30ASK 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 ;
53WALK(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 ;
71RCC(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 ;
87CGV(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 ;
101CCC(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
105SKIP ;;^CacheTemp;^ROUTINE;^mtemp;^mtemp0;^mtemp1;^oddCOM;^oddDEF;^oddMAC;^oddMAP;^oddPROC;^rINC;^rOBJ;^%utility;^%UTILITY;^TMP;^XUTL;^UTILITY;
106exist(fn)
107 n %
108 s %=$zu(140,4,fn)
109 q (%=0)
110 ;
Note: See TracBrowser for help on using the repository browser.