iSharkFly-Open
/
fis-gtm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
fis-gtm/sr_unix/gdeput.m

220 lines
8.5 KiB
Mathematica
Raw Permalink Blame History

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; Copyright 2006, 2012 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(4,regs(s,"EXTENSION"))
s rec=rec_$$num2bin(4,regs(s,"AUTOSWITCHLIMIT"))
s rec=rec_$$num2bin(4,regs(s,"ALIGNSIZE"))
s rec=rec_$$num2bin(4,regs(s,"EPOCH_INTERVAL"))
s rec=rec_$$num2bin(4,regs(s,"SYNC_IO"))
s rec=rec_$$num2bin(4,regs(s,"YIELD_LIMIT"))
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"))
i $ZVersion'["VMS" s rec=rec_$$num2bin(1,regs(s,"INST_FREEZE_ON_ERROR"))
i $ZVersion'["VMS" s rec=rec_$$num2bin(1,regs(s,"QDBRUNDOWN"))
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)
s rec=rec_$tr($j("",SIZEOF("gd_region_padding"))," ",ZERO) ; padding
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
Reference in New Issue View Git Blame Copy Permalink