213 lines
8.2 KiB
Mathematica
213 lines
8.2 KiB
Mathematica
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
; ;
|
||
|
|
; Copyright 2006, 2009 Fidelity Information Services, Inc ;
|
||
|
|
; ;
|
||
|
|
; This source code contains the intellectual property ;
|
||
|
|
; of its copyright holder(s), and is made available ;
|
||
|
|
; under a license. If you do not know the terms of ;
|
||
|
|
; the license, please stop and do not read further. ;
|
||
|
|
; ;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
gdeput: ;output the result of the session to the global directory file
|
||
|
|
GDEPUT()
|
||
|
|
n rec,gds,cregs,csegs,cregcnt,csegcnt,maxrecsize,mapcnt,map
|
||
|
|
d PUTMAKE^GDEMAP
|
||
|
|
s s="",gdeputzs=""
|
||
|
|
f mapcnt=0:1 s s=$o(map(s)) q:'$zl(s) s cregs(map(s))=""
|
||
|
|
s maxrecsize=0
|
||
|
|
f cregcnt=0:1 s s=$o(cregs(s)) q:'$l(s) d
|
||
|
|
. s csegs(regs(s,"DYNAMIC_SEGMENT"))=s i maxrecsize<regs(s,"RECORD_SIZE") s maxrecsize=regs(s,"RECORD_SIZE")
|
||
|
|
f csegcnt=0:1 s s=$o(csegs(s)) q:'$l(s) d fdatum
|
||
|
|
i cregcnt'=csegcnt d error1
|
||
|
|
s x=SIZEOF("gd_contents")+(mapcnt*SIZEOF("gd_map")),s=""
|
||
|
|
f i=0:1 s s=$o(cregs(s)) q:'$l(s) s cregs(s,"offset")=i*SIZEOF("gd_region")+x
|
||
|
|
s x=x+(cregcnt*SIZEOF("gd_region"))
|
||
|
|
f i=0:1 s s=$o(csegs(s)) q:'$l(s) s csegs(s,"offset")=i*SIZEOF("gd_segment")+x
|
||
|
|
s x=x+(csegcnt*SIZEOF("gd_segment"))
|
||
|
|
s rec=""
|
||
|
|
; contents
|
||
|
|
i (gtm64=TRUE) s rec=rec_$c(0,0,0,0,0,0,0,0) ; not used
|
||
|
|
e s rec=rec_$c(0,0,0,0) ; not used
|
||
|
|
s rec=rec_$$num2bin(4,maxrecsize) ; max rec size
|
||
|
|
s filesize=SIZEOF("gd_contents")
|
||
|
|
s rec=rec_$$num2bin(2,mapcnt)_$$num2bin(2,cregcnt)_$$num2bin(2,csegcnt)_$$num2bin(2,0) ; maps,regs,segs,filler
|
||
|
|
i (gtm64=TRUE) d
|
||
|
|
. s rec=rec_$$num2bin(4,0) ; padding
|
||
|
|
. s rec=rec_$$num2bin(8,filesize) ; mapptr
|
||
|
|
e s rec=rec_$$num2bin(4,filesize) ; mapptr
|
||
|
|
s filesize=filesize+(mapcnt*SIZEOF("gd_map"))
|
||
|
|
i (gtm64=TRUE) s rec=rec_$$num2bin(8,filesize) ; regionptr
|
||
|
|
e s rec=rec_$$num2bin(4,filesize) ; regionptr
|
||
|
|
s filesize=filesize+(cregcnt*SIZEOF("gd_region"))
|
||
|
|
i (gtm64=TRUE) s rec=rec_$$num2bin(8,filesize) ; segmentptr
|
||
|
|
e s rec=rec_$$num2bin(4,filesize) ; segmentptr
|
||
|
|
s filesize=filesize+(csegcnt*SIZEOF("gd_segment")),base=filesize
|
||
|
|
i (gtm64=TRUE) d
|
||
|
|
. s rec=rec_$tr($j("",24)," ",ZERO) ; reserved
|
||
|
|
. s rec=rec_$$num2bin(8,filesize) ; end
|
||
|
|
e d
|
||
|
|
. s rec=rec_$tr($j("",12)," ",ZERO) ; reserved
|
||
|
|
. s rec=rec_$$num2bin(4,filesize) ; end
|
||
|
|
s rec=hdrlab_$$num2bin(4,$l(hdrlab)+4+filesize)_rec
|
||
|
|
i create zm gdeerr("GDCREATE"):file
|
||
|
|
e s:$ZVersion["VMS" $p(file,";",2)=$p(file,";",2)+1 zm gdeerr("GDUPDATE"):file
|
||
|
|
s gdexcept="s gdeputzs=$zs zgoto "_$zl_":writeerr^GDEPUT"
|
||
|
|
i $ZVersion["VMS" s tempfile=$p(file,";",1)_"inprogress"
|
||
|
|
e s tempfile=file_"inprogress"
|
||
|
|
;if zchset is UTF-8 open in raw mode to avoid BADCHAR errors
|
||
|
|
; For OS390 aka z/OS, use BINARY mode
|
||
|
|
s chset=$SELECT($ZV["OS390":"BINARY",$ZV["VMS":"",$ZCHSET="UTF-8":"M",1:"")
|
||
|
|
o tempfile:(rewind:noreadonly:newversion:recordsize=512:fixed:blocksize=512:exception=gdexcept:ochset=chset)
|
||
|
|
; maps
|
||
|
|
s s=""
|
||
|
|
f s s=$o(map(s)) q:'$zl(s) d map
|
||
|
|
; cregs
|
||
|
|
f s s=$o(cregs(s)) q:'$l(s) d cregion
|
||
|
|
; csegs
|
||
|
|
f s s=$o(csegs(s)) q:'$l(s) d csegment
|
||
|
|
; template access method
|
||
|
|
i accmeth'[("\"_tmpacc) d error1
|
||
|
|
s rec=rec_$tr($j($l(tmpacc),3)," ",0)
|
||
|
|
s rec=rec_tmpacc
|
||
|
|
; templates
|
||
|
|
f s s=$o(tmpreg(s)) q:'$l(s) s rec=rec_$tr($j($l(tmpreg(s)),3)," ",0) s rec=rec_tmpreg(s)
|
||
|
|
f i=2:1:$l(accmeth,"\") s am=$p(accmeth,"\",i) s s="" d
|
||
|
|
. f s s=$o(tmpseg(am,s)) q:'$l(s) s rec=rec_$tr($j($l(tmpseg(am,s)),3)," ",0),rec=rec_tmpseg(am,s)
|
||
|
|
u tempfile
|
||
|
|
f s record=$ze(rec,1,512),rec=$ze(rec,513,9999) q:'$zl(record) w record,!
|
||
|
|
u @useio
|
||
|
|
i $ZV'["VMS" o file:chset="M" c file:delete
|
||
|
|
c tempfile:rename=file
|
||
|
|
q 1
|
||
|
|
|
||
|
|
;-----------------------------------------------------------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
fdatum:
|
||
|
|
s x=segs(s,"ACCESS_METHOD")
|
||
|
|
s filetype=$s((x="BG")!(x="MM"):"GDS",x="USER":"USER",1:"ERROR")
|
||
|
|
i filetype="ERROR" d error1
|
||
|
|
q
|
||
|
|
map:
|
||
|
|
d writerec
|
||
|
|
i $zl(s)'=SIZEOF("mident") d error1
|
||
|
|
i (gtm64=TRUE) s rec=rec_s_$$num2bin(4,cregs(map(s),"offset"))_$$num2bin(4,0) ; add padding
|
||
|
|
e s rec=rec_s_$$num2bin(4,cregs(map(s),"offset"))
|
||
|
|
q
|
||
|
|
cregion:
|
||
|
|
d writerec
|
||
|
|
s rec=rec_$$num2bin(2,$l(s))
|
||
|
|
s rec=rec_s_$tr($j("",MAXREGLN-$l(s))," ",ZERO)
|
||
|
|
s rec=rec_$$num2bin(2,regs(s,"KEY_SIZE"))
|
||
|
|
s rec=rec_$$num2bin(4,regs(s,"RECORD_SIZE"))
|
||
|
|
i (gtm64=TRUE) d
|
||
|
|
. s rec=rec_$$num2bin(4,csegs(regs(s,"DYNAMIC_SEGMENT"),"offset"))_$$num2bin(4,0) ; padding
|
||
|
|
. s rec=rec_$$num2bin(8,0)
|
||
|
|
e d
|
||
|
|
. s rec=rec_$$num2bin(4,csegs(regs(s,"DYNAMIC_SEGMENT"),"offset"))
|
||
|
|
. s rec=rec_$$num2bin(4,0)
|
||
|
|
s rec=rec_ZERO ; OPEN state
|
||
|
|
s rec=rec_ZERO ; LOCK_WRITE
|
||
|
|
s rec=rec_$c(regs(s,"NULL_SUBSCRIPTS"))
|
||
|
|
s rec=rec_$c(regs(s,"JOURNAL"))
|
||
|
|
s rec=rec_$$num2bin(4,regs(s,"ALLOCATION"))
|
||
|
|
s rec=rec_$$num2bin(2,regs(s,"EXTENSION"))
|
||
|
|
s rec=rec_$$num2bin(2,regs(s,"BUFFER_SIZE"))
|
||
|
|
s rec=rec_$c(regs(s,"BEFORE_IMAGE"))
|
||
|
|
s rec=rec_$tr($j("",4)," ",ZERO) ;filler
|
||
|
|
s rec=rec_$$num2bin(1,regs(s,"COLLATION_DEFAULT"))
|
||
|
|
s rec=rec_$$num2bin(1,regs(s,"STDNULLCOLL"))
|
||
|
|
s rec=rec_$$num2bin(1,$zl(regs(s,"FILE_NAME")))
|
||
|
|
s rec=rec_regs(s,"FILE_NAME")_$tr($j("",SIZEOF("file_spec")-$zl(regs(s,"FILE_NAME")))," ",ZERO)
|
||
|
|
i (gtm64=TRUE) s rec=rec_$tr($j("",12)," ",ZERO) ; reserved + padding
|
||
|
|
e s rec=rec_$tr($j("",8)," ",ZERO) ; reserved
|
||
|
|
q
|
||
|
|
csegment:
|
||
|
|
d writerec
|
||
|
|
s ref=$zl(rec)
|
||
|
|
s am=segs(s,"ACCESS_METHOD")
|
||
|
|
s rec=rec_$$num2bin(2,$l(s))
|
||
|
|
s rec=rec_s_$tr($j("",MAXSEGLN-$l(s))," ",ZERO)
|
||
|
|
s rec=rec_$$num2bin(2,$zl(segs(s,"FILE_NAME")))
|
||
|
|
s rec=rec_segs(s,"FILE_NAME")_$tr($j("",SIZEOF("file_spec")-$zl(segs(s,"FILE_NAME")))," ",ZERO)
|
||
|
|
s rec=rec_$$num2bin(2,segs(s,"BLOCK_SIZE"))
|
||
|
|
s rec=rec_$$num2bin(2,segs(s,"EXTENSION_COUNT"))
|
||
|
|
s rec=rec_$$num2bin(4,segs(s,"ALLOCATION"))
|
||
|
|
i (gtm64=TRUE) s rec=rec_$tr($j("",12)," ",ZERO) ;reserved for clb + padding
|
||
|
|
e s rec=rec_$tr($j("",4)," ",ZERO) ;reserved for clb
|
||
|
|
s rec=rec_".DAT"
|
||
|
|
s rec=rec_$c(+segs(s,"DEFER"))
|
||
|
|
s rec=rec_ZERO ;DYNAMIC segment
|
||
|
|
s rec=rec_$$num2bin(1,segs(s,"BUCKET_SIZE"))
|
||
|
|
s rec=rec_$$num2bin(1,segs(s,"WINDOW_SIZE"))
|
||
|
|
s rec=rec_$$num2bin(4,segs(s,"LOCK_SPACE"))
|
||
|
|
s rec=rec_$$num2bin(4,segs(s,"GLOBAL_BUFFER_COUNT"))
|
||
|
|
s rec=rec_$$num2bin(4,segs(s,"RESERVED_BYTES"))
|
||
|
|
s x=$s(am="BG":1,am="MM":2,am="USER":4,1:-1)
|
||
|
|
i x=-1 d error1
|
||
|
|
s rec=rec_$$num2bin(4,x)
|
||
|
|
i (gtm64=TRUE) d
|
||
|
|
. s rec=rec_$$num2bin(8,0) ; file_cntl ptr
|
||
|
|
. s rec=rec_$$num2bin(8,0) ; repl_list ptr
|
||
|
|
e d
|
||
|
|
. s rec=rec_$$num2bin(4,0) ; file_cntl ptr
|
||
|
|
. s rec=rec_$$num2bin(4,0) ; repl_list ptr
|
||
|
|
; Only for platforms that support encryption, we write this value. Others it will
|
||
|
|
; always be 0 (ie encryption is off)
|
||
|
|
i (encsupportedplat=TRUE) s rec=rec_$$num2bin(4,segs(s,"ENCRYPTION_FLAG"))
|
||
|
|
e s rec=rec_$$num2bin(4,0)
|
||
|
|
i (gtm64=TRUE) s rec=rec_$$num2bin(4,0)
|
||
|
|
q
|
||
|
|
|
||
|
|
;-----------------------------------------------------------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
num2bin:(l,n)
|
||
|
|
i (gtm64=TRUE) q $s(l=1:$$num2tiny(+n),l=2:$$num2shrt(+n),l=4:$$num2int(+n),l=8:$$num2long(+n),1:$$num2error)
|
||
|
|
e q $s(l=1:$$num2tiny(+n),l=2:$$num2shrt(+n),l=4:$$num2int(+n),1:$$num2error)
|
||
|
|
;
|
||
|
|
num2tiny:(num)
|
||
|
|
i (num<0)!(num'<256) d error1
|
||
|
|
q $zch(num)
|
||
|
|
;
|
||
|
|
num2shrt:(num)
|
||
|
|
i (num<0)!(num'<TWO(16)) d error1
|
||
|
|
i endian=TRUE q $zch(num\256,num#256)
|
||
|
|
e q $zch(num#256,num\256)
|
||
|
|
;
|
||
|
|
num2int:(num)
|
||
|
|
i (num<0)!(num'<TWO(32)) d error1
|
||
|
|
i endian=TRUE q $zch(num\TWO(24),num\TWO(16)#256,num\TWO(8)#256,num#256)
|
||
|
|
e q $zch(num#256,num\TWO(8)#256,num\TWO(16)#256,num\TWO(24))
|
||
|
|
;
|
||
|
|
num2long:(num)
|
||
|
|
n t8,t16,t24,t32,t40,t48,t56
|
||
|
|
s t8=TWO(8),t16=TWO(16),t24=TWO(24),t32=TWO(32),t40=TWO(40),t48=TWO(48),t56=TWO(56)
|
||
|
|
i (num<0)!(num'<TWO(64)) d error1
|
||
|
|
i endian=TRUE q $zch(num\t56,num\t48#256,num\t40#256,num\t32#256,num\t24#256,num\t16#256,num\t8#256,num#256)
|
||
|
|
e q $zch(num#256,num\t8#256,num\t16#256,num\t24#256,num\t32#256,num\t40#256,num\t48#256,num\t56)
|
||
|
|
;
|
||
|
|
num2error:()
|
||
|
|
d error1
|
||
|
|
q 0
|
||
|
|
|
||
|
|
;----------------------------------------------------------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
fatal:(msgno)
|
||
|
|
q msgno\8*8+4
|
||
|
|
;
|
||
|
|
error1:
|
||
|
|
s $et="d ABORT^GDE"
|
||
|
|
c tempfile:delete
|
||
|
|
zm $$fatal(gdeerr("VERIFY")):"FAILED"
|
||
|
|
;
|
||
|
|
writerec:
|
||
|
|
i $zl(rec)<512 q
|
||
|
|
s record=$ze(rec,1,512),rec=$ze(rec,513,9999)
|
||
|
|
u tempfile w record,! u @useio
|
||
|
|
q
|
||
|
|
;
|
||
|
|
writeerr
|
||
|
|
u @useio
|
||
|
|
c tempfile:delete
|
||
|
|
zm gdeerr("WRITEERROR"):gdeputzs
|
||
|
|
q 0
|