;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; Copyright 2006, 2010 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. ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; gdeget: ;read in an existing GD or create a default LOAD n abs,contents,rel,xregs,xsegs,reglist,map,$et i debug s $et="b" e s $et="g ABORT^GDE:($p($p($zs,"","",3),""-"")'=""%GDE"") u io w !,$p($zs,"","",3,999),! h" ; if zchset is UTF-8 open in raw mode to avoid BADCHAR errors ; For OS390 aka z/OS, use BINARY mode s abs=1,update=0,chset=$SELECT($ZV["OS390":"BINARY",$ZV["VMS":"",$ZCHSET="UTF-8":"M",1:"") o file:(exc="g badfile":rewind:recordsize=SIZEOF("dsk_blk"):readonly:fixed:blocksize=SIZEOF("dsk_blk"):ichset=chset) u file r rec i debug u @useio ; header s label=$ze(rec,1,12) s mach=$p($zver," ",4) s seghasencrflag=FALSE if ($e(label,0,9)="GTCGBDUNX"),$e(label,$l(label)-1,99)>5 s seghasencrflag=TRUE set v534=0 i (label="GTCGBDUNX105")!((label="GTCGBDUNX005")&(mach="IA64")) s label=hdrlab,v534=1,update=1 ;autoconvert i (v534=1) n SIZEOF d v534init set v533=0 i (gtm64=TRUE),(label="GTCGBDUNX006") s label=hdrlab,v533=1,update=1 ;autoconvert i (v533=1) n SIZEOF d v533init set v532=0 i (label="GTCGBLDIR008")!(label="GTCGBDUNX005") s label=hdrlab,v532=1,update=1 ;autoconvert i (v532=1),(mach'="IA64") n gtm64 s gtm64=FALSE i (v532=1),(mach'="IA64") n SIZEOF d v532init set v5ft1=0 i (label="GTCGBLDIR008")!(label="GTCGBDUNX004") s label=hdrlab,v5ft1=1,update=1 ;autoconvert i v5ft1=1 n gtm64 s gtm64=FALSE i v5ft1=1 n SIZEOF d v5ft1init set v44=0 i (label="GTCGBLDIR007")!(label="GTCGBDUNX003") s label=hdrlab,v44=1,update=1 ;autoconvert i v44=1 n gtm64 s gtm64=FALSE i v44=1 n MAXNAMLN,MAXSEGLN,MAXREGLN,SIZEOF d v44init s v30=0 i (label="GTCGBLDIR006")!(label="GTCGBDUNX002") s label=hdrlab,v30=4,update=1 ;autoconvert i v30=4 n gtm64 s gtm64=FALSE i label'=hdrlab d cretmps,CONVERT^GDEOGET,verify s encryptsupported=FALSE,update=1 q ;autoconvert s filesize=$$bin2num($ze(rec,13,16)) s abs=abs+SIZEOF("gd_header") ; contents i (gtm64=TRUE) d . i $ze(rec,abs,abs+7)'=$c(0,0,0,0,0,0,0,0) zm gdeerr("INPINTEG") ; filler . s abs=abs+8 e d . i $ze(rec,abs,abs+3)'=$c(0,0,0,0) zm gdeerr("INPINTEG") ; filler . s abs=abs+4 s contents("maxrecsize")=$$bin2num($ze(rec,abs,abs+3)),abs=abs+4 s contents("mapcnt")=$$bin2num($ze(rec,abs,abs+1)),abs=abs+2 s contents("regioncnt")=$$bin2num($ze(rec,abs,abs+1)),abs=abs+2 s contents("segmentcnt")=$$bin2num($ze(rec,abs,abs+1)),abs=abs+2 i $ze(rec,abs,abs+1)'=$tr($j("",2)," ",ZERO) zm gdeerr("INPINTEG") ; filler i (gtm64=TRUE) d . s abs=abs+6 ; including padding . s contents("maps")=$$bin2num($ze(rec,abs,abs+7)),abs=abs+8 . s contents("regions")=$$bin2num($ze(rec,abs,abs+7)),abs=abs+8 . s contents("segments")=$$bin2num($ze(rec,abs,abs+7)),abs=abs+8 . s abs=abs+24 ;skip link, tab_ptr and id pointers . s contents("end")=$$bin2num($ze(rec,abs,abs+7)),abs=abs+8 e d . s abs=abs+2 . s contents("maps")=$$bin2num($ze(rec,abs,abs+3)),abs=abs+4 . s contents("regions")=$$bin2num($ze(rec,abs,abs+3)),abs=abs+4 . s contents("segments")=$$bin2num($ze(rec,abs,abs+3)),abs=abs+4 . s abs=abs+12 ;skip link, tab_ptr and id pointers . s contents("end")=$$bin2num($ze(rec,abs,abs+3)),abs=abs+4 i contents("regioncnt")'=contents("segmentcnt") zm gdeerr("INPINTEG") i contents("regioncnt")-1>contents("mapcnt") zm gdeerr("INPINTEG") ; verify offsets i abs'=(SIZEOF("gd_header")+SIZEOF("gd_contents")+1) zm gdeerr("INPINTEG") s x=contents("maps") i x+1'=(abs-SIZEOF("gd_header")) zm gdeerr("INPINTEG") s x=x+(contents("mapcnt")*SIZEOF("gd_map")) i x'=contents("regions") zm gdeerr("INPINTEG") s x=x+(contents("regioncnt")*SIZEOF("gd_region")) i x'=contents("segments") zm gdeerr("INPINTEG") s x=x+(contents("segmentcnt")*(SIZEOF("gd_segment")-v30)) i x'=contents("end") zm gdeerr("INPINTEG") s rel=abs ; maps - verify that mapped regions and regions are 1-to-1 k reglist f i=1:1:contents("mapcnt") d map zm:'$$MAP2NAM^GDEMAP(.map) gdeerr("INPINTEG") s s="" f i=1:1:contents("regioncnt") s s=$o(reglist(s)) i $l($o(reglist(s))) zm gdeerr("INPINTEG") ; regions k regs,xregs s regs=0 f i=1:1:contents("regioncnt") d region i regs'=contents("regioncnt") zm gdeerr("INPINTEG") ; segments k segs,xsegs s segs=0 f i=1:1:contents("segmentcnt") d segment i segs'=contents("segmentcnt") zm gdeerr("INPINTEG") ; template access method s tmpacc=$$gderead(4) i accmeth'[("\"_tmpacc) zm gdeerr("INPINTEG") ; templates k tmpreg,tmpseg d cretmps f s="ALLOCATION","BEFORE_IMAGE","BUFFER_SIZE" d tmpreg(s) i 'v30 d tmpreg("COLLATION_DEFAULT") f s="EXTENSION","FILE_NAME" d tmpreg(s) f s="JOURNAL","KEY_SIZE","NULL_SUBSCRIPTS","RECORD_SIZE" d tmpreg(s) ;,"STOP_ENABLE" ; need to handle versioning i 'v44&'v30 d tmpreg("STDNULLCOLL") ; minimum allocation/extension was changed in V54001; check if default current value is lower and if so adjust it i tmpreg("ALLOCATION") number n num,i s num=0 i endian=TRUE f i=$zl(bin):-1:1 s num=$za(bin,i)*HEX($zl(bin)-i*2)+num e f i=1:1:$zl(bin) s num=$za(bin,i)*HEX(i-1*2)+num q num ; ;---------------------------------------------------------------------------------------------------------------------------------- map: i $zl(rec)-(rel-1)max zm gdeerr("INPINTEG") i $zl(rec)-(rel-1)