JRNDUMP	;dump the contents of a journal file ; APJ853 01/18/00  ; Compiled March 6, 2000 19:36:05
	; +--------------------------------------------------------+
	; | Copyright 1986-2000 by InterSystems Corporation,       |
	; | Cambridge, Massachusetts, U.S.A.                       |
	; | All rights reserved.                                   |
	; |                                                        |
	; | Confidential, unpublished property of InterSystems.    |
	; |                                                        |
	; | This media contains an authorized copy or copies       |
	; | of material copyrighted by InterSystems and is the     |
	; | confidential, unpublished property of InterSystems.    |
	; | This copyright notice and any other copyright notices  |
	; | included in machine readable copies must be reproduced |
	; | on all authorized copies.                              |
	; +--------------------------------------------------------+
	;%system.INC ; DAS280 06/29/99 
	;%ST.INC DAS309 11/08/99 
	; %system.inc: compiled for NETWIDENAMESPACE
	; %system.inc: compiled for DDPGROUPS
	; %system.inc: compiled for NETMOREDCPDMN
	; %system.inc: compiled for USECLUSTER
	; %system.inc: compiled for RTNINGBL
	; %system.inc: compiled for DBMSNSP
	;this section is for level 1 display (a list of journal files)       
	;these section is for level 2 display (a list of journal records)
	; this section is for both level 1 and level 2 display 
	; RECSTART is the row # preceding the first record/journal line
	; major entry points for GUI are listjrn, thisrec, and nextrec.
	; see individual entry points for documentation.         
	n
	q:$zj\2#2
	s blank=$j("",80),rm=80,rate=5,delim=$$del2^%Wprim
	s $p(sep,"=",80)=""
	s endjrn=$zu(78,3)
	s:endjrn="" endjrn=$p($g(^%SYS("JOURNAL","LAST")),"^",2)
	i endjrn="" w "no journal file to begin with",! q
	s refresh=1,jf=endjrn,begjrn=$$listjrn(endjrn,.list,-18),i=18
	f  d  q:'key
	. i refresh w /ed(2) d listhdr,showlist(.list)
	. d showcur(i) s refresh=1,jf=list(i)
	. s key=$$getkey1 q:'key
	. i key=4 d onejrn(jf) q
	. i +key=3,$l(key)>1 d onejrn($e(key,2,$l(key))) q
	. i key=1!(key=5&(i=18)) d  q
	. . s begjrn=endjrn,endjrn=$$listjrn(begjrn,.list,18),i=1 q
	. i key=2!(key=6&(i=1)) d  q
	. . s endjrn=begjrn,begjrn=$$listjrn(endjrn,.list,-18),i=18 q
	. i key=5,jf'=endjrn d movecur(.i,1) s jf=list(i),refresh=0 q
	. i key=6,jf'=begjrn d movecur(.i,-1) s jf=list(i),refresh=0 q
	q
getkey1()	;
	w /cup(23,1),"(N)ext,(P)rev,(G)oto,(E)xamine,(Q)uit => "
	u 0:(:"+S")
	f  r key#1  q:"NPQEGnpqeg"[key
	u 0:(:"-S")
	i "Qq"[key q 0 ;quit ("Q","q","")
	i key="N" q 1  ;next page
	i key="P" q 2  ;prev page
	i "Gg"[key n jrnfile d  q 3_jrnfile
	. s row=23+1
	. w /cup(row,1),"File: " r jrnfile q:jrnfile=""
	. s jrnfile=$zu(12,jrnfile)
	. i $zu(78,22,jrnfile)'=1 d 
	. . d message(jrnfile_" is invalid journal file",2,row) 
	. . s jrnfile=""
	i "Ee"[key q 4 ;examine
	i key="n" q 5  ;next row
	i key="p" q 6  ;prev row
	q -1
progress(f)	
	i +$zu(78,22) s co=$zu(78,4) d
	. w /cup(4,(((((1+10+1)+8+1)+2+1)+16+1)+8+1)),$j((co*100)\$p($zu(78,22,f,3),",",2)_"%",8)   
	q
listhdr	;
	w /cup(3-1,1),?3,$j("Journal",12)
	w ?(((1+10+1)+8+1)+2+1),"Directory" ;,?$$$STAO,$j("Status",$$$STAL)
	;w ?$$$PRGO,$j("Progress",$$$PRGL)
	w !,sep,!
	q
showlist(l)	;show directory too??
	n (l)
	s i="" f  s i=$o(l(i)) q:i=""  d
	. w /cup(i+3,1),?3,$S($F(l(i),";"):$E(l(i),$F(l(i),";")-12-1,$f(l(i),";")-2),1:$E(l(i),$L(l(i))-11,$L(l(i))))
	. w ?(((1+10+1)+8+1)+2+1),$$basename(l(i))
	q
listjrn(f,list,n)	;list at most n journal files from f, return the n-th file
	n (f,n,list)
	s:$zu(78,22,f)<1 f=""                                   ;KLMxxx
	s jf=f q:'n 
	k list
	i n<0 s i=-n+1 d  q list(i)
	. f  s i=i-1,list(i)=jf q:i=1  s x=$$PREVJRN^JRNUTIL2(jf,.jf) q:x'>0  q:$zu(78,22,jf)<1  ; KLMxxx
	s i=0 f  s i=i+1,list(i)=jf q:i=n  s jf=$$NEXTJRN0^JRNUTIL(jf) q:jf=""
	q list(i)
guijrn(f,list,context)	;gui entry point, fetch last n journal files from f in .list
	n (f,list,context,files)
	i context<0 d  ;build array of files
	. k files
	. i f="" s f=$p($g(^%SYS("JOURNAL","LAST")),"^",2) ;journalling is off, start with last file
	. s x=$$listjrn(f,.list,-99999)
	. s x="" f  s x=$o(list(x)) q:x=""  s val=$g(list(x)) s:val'="" files(val)=x
	. ;add items from \journal directory that aren't in list
	. k list
	. s path=$p(f,"\journal\",1)_"\journal\*.*"
	. f  s file=$zse(path) q:file=""  d
	. . s path=""
	. . i $e(file,$l(file)-11,$l(file))?8n1"."3n s files(file)=""
	e  s file=context
	s del=$$del1^%Wprim,list=""
	f i=1:1:100 s file=$o(files(file),-1) q:file=""  s list=list_$s(i=1:"",1:del)_file,context=file
	q $l(list)
prevjrn(f)	;
	n (f)
	s x=$zu(78,22,f,1) q:+x'=1 0  ;f is not found or not a journal file
	i $p(x,",",2)'="" s f=$p(x,",",2) q $s($zu(78,22,f)'=1:-1,1:1)  ;switch journal
	; f is a START journal. looking for a STOP journal preceding f
	s found=0,short=$S($F(f,";"):$E(f,$F(f,";")-12-1,$f(f,";")-2),1:$E(f,$L(f)-11,$L(f))),date=$zdateh($p(short,"."),5)
	s x="" f  s x=$o(^SYS("JOURNAL","HISTORY",date,x),-1) q:x=""  d  q:found
	. s f=$p(^SYS("JOURNAL","HISTORY",date,x),"^",3)
	. i short>$S($F(f,";"):$E(f,$F(f,";")-12-1,$f(f,";")-2),1:$E(f,$L(f)-11,$L(f))) s found=1 q
	i found q $s($zu(78,22,f)'=1:-1,1:2)
	s date=$o(^SYS("JOURNAL","HISTORY",date),-1) q:date="" -1 ;none previous       
	s x=$o(^SYS("JOURNAL","HISTORY",date,""),-1) q:x="" -1 ;none previous
	s f=$p(^SYS("JOURNAL","HISTORY",date,x),"^",3) 
	q $s($zu(78,22,f)'=1:-1,1:2)  ;found a STOP journal   
showcur(i)	;
	w /cup(i+3,1),">"
	q        
movecur(i,n)	;
	w /cup(i+3,1)," "
	s i=i+n
	w /cup(i+3,1),">"
	q
onejrn(jf)	;view a journal file
	s $zt="etonejrn"
	n (jf)
	s jf=$zu(12,jf)
	s dev=$zu(78,5,jf,0) 
	i dev<0 d  q
	. w /ed(2) w /cup(1,1),"unable to open file "_jf,! 
	. r "press any key to return",x#1
	i $zu(78,6,dev)
	s blank=$j("",80),$p(sep,"=",80)=""
	d pagehdr(jf)
	s begaddr=0
	f  s endaddr=$$onepage(begaddr) d stat(jf) s key=$$getkey q:'key  d:$zu(78,17,0)
	. i key=1,endaddr s begaddr=endaddr q
	. i key=2,begaddr s begaddr=$$jump(begaddr,-18) q
	. i key=3 d goto(.begaddr) q
	. i key=4 d findrec(.begaddr) q
	. i key=5 k addr d goto(.addr) d:$d(addr)  q
	. . d examine(jf,addr)
	. . d pagehdr(jf)
	i $d(dev),dev'<0,$zu(78,7,dev)
	q        
etonejrn	;
	s $zt=""
	i $d(dev),dev'<0,$zu(78,7,dev)
	w !!,"error: ",$ze,!
	r " press any key to continue ",x#1,!
	q
stat(jf)	;
	w /cup(23-1,1)
	w "Last record: ",$j($zu(78,18,$zu(78,18,0)),10)_";   "
	w "Max size: ",$j($P($ZU(78,22,jf,3),",",2),10)
	q
guistat(jf)	    ;
	;return last record
	q $zu(78,18,$zu(78,18,0))
	;
getkey()	;
	w /cup(23,1),"(N)ext,(P)rev,(G)oto,(F)ind,(E)xamine,(Q)uit => "
	u 0:(:"+S")
	f  r key#1  q:"NPQEFGnpqefg"[key
	u 0:(:"-S")
	i "Qq"[key q 0 ;quit ("Q","q","")
	i "Nn"[key q 1 ;next page
	i "Pp"[key q 2 ;prev page
	i "Gg"[key q 3 ;goto
	i "Ff"[key q 4 ;find
	i "Ee"[key q 5 ;examine
	q -1
goto(addr)	
	n (addr)
	s row=23+1
	f  d  q:+x=0  s p=$zu(78,18,x) q:p'<0  d message("invalid address",1,row)
	. w /cup(row,1),"Address: " r x
	i x?1.N s addr=$s('x:$zu(78,17,x),$zu(78,17,p)=x:$zu(78,17,p),1:p) 
	d message("",0,row)
	q
findrec(addr)	;find a 
	n (addr)
	s row=23+1
	w /cup(row,1),"(F)orward/(B)ackward search =>"
	u 0:(:"+S")
	f  r x#1 q:"FfBb"[x
	u 0:(:"-S")
	w /cup(row,1)
	i x="" d message("",0,row) q
	i "Ff"[x r "Forward search for string:    ",str s func=17
	i "Bb"[x r "Backward search for string:   ",str s func=18
	d message("",0,row) i str="" q
	w /cup(row,1),"searching..."
	s a=addr,found=0 f  s a=$zu(78,func,a) q:a'>0  d  q:found 
	. s rec=$$thisrec(a,.glo,.val)
	. i rec'[str,$g(glo)'[str,$g(val)'[str q
	. s found=1
	i found s addr=a 
	e  d message("string not found",1,row)
	d message("",0,row)
	q
guifind(addr,str,case)	;gui entry point, find str starting at addr
	n (addr,str,case)
	s a=addr,found=0 f  s a=$zu(78,17,a) q:a'>0  d  i found s addr=a q
	. s rec=$$thisrec(a,.glo,.val)
	. s ustr=$ZCVT(str,"U")
	. i 'case,$ZCVT(rec,"U")'[ustr,$ZCVT($g(glo),"U")'[ustr,$ZCVT($g(val),"U")'[ustr q
	. i case,rec'[str,$g(glo)'[str,$g(val)'[str q
	. s found=1
	i 'found s addr=0
	q 1
examine(jf,addr)	;
	f  d  q:"Qq"[x  s addr=$s("Nn"[x:$zu(78,17,addr),1:$zu(78,18,addr)) q:addr'>0
	. w /ed(2),/cup(1,1),"Journal: ",jf,!! 
	. d dumprec(addr)
	. w /cup(25,1),"(N)ext,(P)rev,(Q)uit => "
	. u 0:(:"+s")
	. f  r x#1 q:"QNPqnp"[x
	. u 0:(:"-s")
	q 
dumprec(addr)	;
	n (addr) w /cup(3,1) s offset=25
	w "Address: ",?offset,addr,! s type=$zu(78,8,addr)
	w "Type: ",?offset,$$Type(type),! s trans=$zu(78,9,addr)
	w "In transaction: ",?offset,$s(trans:"Yes",1:"No"),!
	w "Process ID: ",?offset,$zu(78,10,addr),!
	w "Remote system ID: ",?offset,$ZU(78,25,addr),!
	w "Time stamp: ",?offset,$zu(78,24,addr),!
	w "Collation sequence: ",?offset,$ZU(78,27,addr),!
	w "Prev address: ",?offset,$zu(78,18,addr),!
	w "Next address: ",?offset,$zu(78,17,addr),!
	w:+$ZU(40,2,95) "Cluster sequence #: ",?offset,$zu(78,11,addr)
	w !
	w "Global:    ",$zu(78,13,addr),! s numdata=$zu(78,14,addr)
	i numdata=2 d  q
	. w "New Value: ",$zu(78,15,addr),!
	. w "Old Value: ",$zu(78,16,addr),!   
	i numdata>0 d  q
	. i type-6,type-10 w "New Value: ",!,"Old Value: ",$zu(78,16,addr),!
	. e  w "New Value: ",$zu(78,15,addr),!   
	q
message(msg,hangval,row)	
	w /cup(row,1),msg,$j("",80-$x) h hangval 
	w /cup(row,1),$j("",80) 
	q
clear(first,last)	
	w /cup(first,1)
	f i=first:1:last w /cup(i,1),blank 
	w /cup(1,1)
	q
pagehdr(jf)	;
	d clear(1,25)
	w /cup(1,1),"Journal: ",jf
	w /cup(3-1,1),$j("Address",10),?(1+10+1),$j("Proc ID",8)
	w ?((1+10+1)+8+1),"Op",?(((1+10+1)+8+1)+2+1),"Directory",?((((1+10+1)+8+1)+2+1)+16+1),"Global & Value",!
	w sep,!
	q
onepage(addr)	;assume journal is in use, addr: starting record
	n (addr,blank)
	i 'addr s addr=$zu(78,17,addr) q:addr'>0 0
	s rec=$$thisrec(addr,.glo,.val),i=1 
	f  q:+rec'>0  d showrec(rec,$g(glo),$g(val),i) q:i=18  d
	. s addr=+rec,rec=$$nextrec(addr,.glo,.val),i=i+1
	d clear(3+i,23-1)
	q +rec
	;
thisrec(addr,glo,val)	;return the record at addr
	n (addr,glo,val)
	s $zt="etrecord",d=$$del2^%Wprim
	s op=$$OPER($zu(78,8,addr),$zu(78,9,addr))
	i op'["B",op'["C" d  i 1
	. s glo=$zu(78,13,addr),glo=$p(glo,"]",$l(glo,"]"))
	. s:op["S" val=$zu(78,15,addr)
	e  s (glo,val)=""
	q addr_d_$zu(78,10,addr)_d_op_d_$zu(78,12,addr)
nextrec(addr,glo,val)	;return the record following addr
	n (addr,glo,val)
	s $zt="etrecord",d=$$del2^%Wprim
	s addr=$zu(78,17,addr) q:addr'>0 addr
	s op=$$OPER($zu(78,8,addr),$zu(78,9,addr))
	i op'["B",op'["C" d  i 1
	. s glo=$zu(78,13,addr),glo=$p(glo,"]",$l(glo,"]"))
	. s:op["S" val=$zu(78,15,addr)
	e  s (glo,val)=""
	q addr_d_$zu(78,10,addr)_d_op_d_$zu(78,12,addr)
etrecord	
	s $zt=""
	q 0_$$del1^%Wprim_$zt
guirecs(addr,data,size,dir)	;gui entry point, fetch screenful
	;Detect maxstring before setting. 
	n (addr,data,size,dir)
	s del2=$$del2^%Wprim,del1=$$del1^%Wprim
	s (data,glo,val)=""
	s stop=0
	f i=1:1:size d  q:addr=0!(stop=1)
	. s nextaddr=$$jump(addr,dir)
	. i nextaddr=addr s addr=0,data=data_"." q
	. s addr=nextaddr
	. s rec=$$thisrec(addr,.glo,.val)_del2_glo_del2_$e(val,1,500)
	. i $l(data)+$l(rec)>10000 s stop=1 q
	. i dir=1 s data=data_rec_del1
	. e  s data=rec_del1_data
	i stop q 2
	q 1
OPER(type,trans)	
	n (type,trans)
	q:type=4 "BT"
	q:type=5 "CT"
	q:type<4!(type>12) "*"
	i type=7!(type=11) s op="K"
	e  i type=9!(type=12)!(type=8) s op="k"
	e  s op="S"
	s:trans op=op_"T"
	q op
showrec(rec,glo,val,n)	;display record at line n. 
	n (rec,glo,val,n)
	;s glo=$g(glo),val=$g(val),n=+$g(n)
	i n d  q
	. s row=n+3,d=$$del2^%Wprim
	. w /cup(row,1),$j($p(rec,d),10)
	. w ?(1+10+1),$j($p(rec,d,2),8)
	. w ?((1+10+1)+8+1),$p(rec,d,3)
	. w ?(((1+10+1)+8+1)+2+1),$$truncate($p(rec,d,4),16)
	. w ?((((1+10+1)+8+1)+2+1)+16+1),$$truncate(glo,(80-10-8-2-16))
	. s roomleft=80-$x 
	. i $p(rec,d,3)["S",roomleft w " = ",$$truncate(val,80-$x)
	. w $j("",80-$x)
	q
truncate(str,len)	;truncate a string to max len and append a "+" if truncated
	n (str,len)
	i $l(str)'>len q str
	q $e(str,1,len-1)_"+"
jump(addr,n)	;return address of record n from addr (record 0 at addr)
	n (addr,n)
	i 'n q addr
	i n>0 s func=17
	e  s func=18,n=-n
	f i=1:1:n s new=$zu(78,func,addr) q:new'>0  s addr=new
	q addr
	; BITWISE.INC, DPB139 07/09/93
FIXDIR(dir)	;procedure, dir is passed by reference
	Q:dir=""
	i ($zv["VMS") d
	. n x
	. s x=$$ChkDirVALID(dir)
	. i x'="" s dir=x
	i '($zv["VMS") Q:$A(dir,$L(dir))=$A($s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:""))
	i '($zv["VMS") s dir=dir_$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:"")
	Q
fixdir(dir)	;function
	Q:dir="" ""
	i ($zv["VMS") d  q dir
	. n x
	. s x=$$ChkDirVALID(dir)
	. i x'="" s dir=x
	Q:$A(dir,$L(dir))=$A($s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:"")) dir
	Q dir_$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:"")
basename(f)	;similar to basename on UNIX
	Q $P(f,$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:""),1,$L(f,$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:""))-1)_$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:"")
appdir(d1,d2)	;use $zu(12,d2) to append d2 to canonic dir
	i ($zv["VMS") S $E(d1,$L(d1))="."_d2_"]"
	i '($zv["VMS") S d1=d1_d2
	Q d1
VALIDIR(dir)	;validate directory dir and create it if dir doesn't exist
	new flag
	s flag=1
	g vdir2
validir(dir,flag)	;validate directory dir and optionally create it if it
vdir2	; VALIDIR(dir) comes here with flag set to 1
	quit:$$ChkDirOrSpecEXISTS(dir)'="" 1   ; dir is valid and exists
	quit:$$ChkDirVALID(dir)="" 0    ; dir is not valid
	i flag'=1 q 0  ; flag says don't create, return failure
	new x
	set x=$$mkdir(dir)  ; returns 0 for success, 1 for failure
	q:x=1 0  ; failed to create
	quit:$$ChkDirOrSpecEXISTS(dir)="" 0   ; it doesn't we failed
	q 1  ; success
mkdir(dir)	;create a new directory
	i '($zv["VMS") Q $ZF(-1,"mkdir "_$S($E(dir)=""""!($F(dir," ")=0):dir,1:""""_dir_""""))
	q:$$ChkDirVALID(dir)="" 1  ; dir is invalid, return failure
	n res
	s res=$ZF(-1,"create/directory "_dir)
	q '+($ZBOOLEAN(+(res),+(1),1)) 
jrnshort(jf,short)	;get/set short form of a journal file name
	N (jf,short)
	S len=$L($P(jf,";"))
	Q:$G(short)="" $E(jf,len-11,len) ;"GET" form
	S $E(jf,len-11,len)=short ;"SET" form
	Q jf
GJrnPrefix(jf)	;extract prefix from the journal file name jf
	N (jf)
	S fname=$P(jf,$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:""),$L(jf,$s(($zv["UNIX"):"/",($zv["VMS"):"]",($zv["Windows"):"\",1:"")))       
	i '($zv["VMS") Q $E(fname,1,$L(fname)-12)
	S fname=$P(fname,";")
	Q $E(fname,1,$L(fname)-12)
dirinvalidmsg(dir1,dir2)	
	n valid1,valid2,cnt,msg
	s valid1=$$VALIDIR(dir1),valid2=$$VALIDIR(dir2)
	s cnt=valid1+valid2 ; cnt = 0 if both invalid, 1 if one is valid
	s msg="The following journaling "
	s:cnt msg=msg_"directory is" 
	s:'cnt msg=msg_"directories are"
	s msg=msg_" not valid"_$C(13,10)
	s:'valid1 msg=msg_"     "_dir1_$C(13,10)
	s:'valid2 msg=msg_"     "_dir2_$C(13,10)
	q msg
ChkDirVALID(R)	N N S $ZE="",$ZT="ChkBad",N=$ZU(12,R,1) Q N
ChkDirEXISTS(R)	N N S $ZE="",$ZT="ChkBad",N=$ZU(12,R,2) Q N
ChkDirOrSpecEXISTS(R)	N N S $ZE="",$ZT="ChkBad",N=$ZU(12,R,3) Q N
ChkDir(R)	N N S $ZE="",$ZT="ChkBad",N=$ZU(12,R,2) Q N
ChkBad	S $ZT="" W !,"<"_$P($P($ZE,"<",2),">")_"> error -- invalid directory"
	Q ""
Type(t)	;return the transaction name
	I t=4 Q "BeginTrans"
	I t=5 Q "CommitTrans"
	I t=6 Q "Set"
	I t=7 Q "KillNode"
	I t=8 Q "KillDesc"
	I t=10 Q "NSet"
	I t=11 Q "NKill"
	I t=9 q "ZKill"
	i t=12 q "NZKill"
	I t=-1 Q "JOURNAL-END"
	Q "***"