fis-gtm-6.3-000a 6.3-000A-1 / usr / lib / x86_64-linux-gnu / fis-gtm / V6.3-000A_x86_64 / _PEEKBYNAME.m

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;								;
; Copyright (c) 2015-2016 Fidelity National Information		;
; Services, Inc. and/or its subsidiaries. All rights reserved.	;
;								;
;	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.	;
;								;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Calls $ZPEEK() with proper offset, length and format based on the info given in ^gtmtypes global
;
; field: specifies the memory location that needs to be accessed in the C-style dotted format i.e. CONTROL_BLOCK[.FIELD].* (For
;        example "gd_region.max_key_size")
; regindex: (Optional) a region name, structure index or a base address that is associated with the first (field name) argument.
;        The choice is governed by the following rules applied in the following order:
;
;	1. If the value is a hex value in the form of "0xhhhhhhhh[hhhhhhhh]", then it is used as the base address of the data to
;          fetch. Also in this case, the offset, length, and type are taken from the field specified in the first expression (field)
;          See the $ZPEEK() function description of the "PEEK" mnemonic for more information.
;
;	2. If the first expression refers to one of the region-related structures supported by the $ZPEEK() function, this second
;          expression is treated as a region name.
;
;	3. If the first expression refers to one of the replication related structures supported by the $ZPEEK() function that are
;          indexed, this second expression is treated as a numerical (base 10) index value.
;
;	4. For those structures supported by the $ZPEEK() function that do not accept an argument, this second expression must be
;          NULL or not specified.
;
; format: (Optional) specifies the output format in one character as defined in the "format" argument in the $ZPEEK() documentation.
;        This argument overrides the automatic format detection by the %PEEKBYNAME utility.

%PEEKBYNAME(field,regindex,format)
	if '$quit write "GTM-E-EXTRINSIC Use $$ rather than DO to invoke ",$text(+0) quit
	new anindexval,aregname,digits,etrap,first,ishexnum,land,length,mnemonicandreg,offset,pattern,rest,type,typeindex
	set etrap=$etrap
	new $etrap	; Do not modify caller's error trap
	set $ecode="",$etrap="quit"	; Defer error handling to the caller without doing anything
	set land=$zlevel-1
	set anindexval="an index value",aregname="a region name"
	set field=$zconvert($get(field),"L")
	set first=$piece(field,".",1)
	set rest=$piece(field,".",2,$length(field,"."))
	do:""=rest error("NOFIELD")
	set digits=$select("x86"=$p($zver," ",4):8,1:16)
	set regindex=$get(regindex)
	; Is regindex a hex number in the acceptable address range (1-8 digits on 32-bit platforms and 1-16 digits on 64-bit)?
	set pattern=""""_regindex_"""?1""0x""1."_digits_"(1N,1""A"",1""B"",1""C"",1""D"",1""E"",1""F"")"
	set @("ishexnum=("_pattern_")")
	; PEEK takes a hexadecimal number as the regindex
	if ishexnum&(""'=field) set mnemonicandreg="PEEK:"_regindex
	else  if "sgmnt_addrs"=first do:""=regindex error("PARMREQ",first,aregname) set mnemonicandreg="CSAREG:"_regindex
	else  if "sgmnt_data"=first do:""=regindex error("PARMREQ",first,aregname) set mnemonicandreg="FHREG:"_regindex
	else  if "gd_region"=first do:""=regindex error("PARMREQ",first,aregname) set mnemonicandreg="GDRREG:"_regindex
	else  if "gtmsrc_lcl"=first do:""=regindex error("PARMREQ",first,anindexval) set mnemonicandreg="GLFREPL:"_regindex
	else  if "gtmrecv_local_struct"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="GRLREPL"
	else  if "gtmsource_local_struct"=first do:""=regindex error("PARMREQ",first,anindexval) do
	.	set mnemonicandreg="GSLREPL:"_regindex
	else  if "jnl_buffer"=first do:""=regindex error("PARMREQ",first,aregname) set mnemonicandreg="JBFREG:"_regindex
	else  if "jnl_private_control"=first do:""=regindex error("PARMREQ",first,aregname) set mnemonicandreg="JNLREG:"_regindex
	else  if "jnlpool_ctl_struct"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="JPCREPL"
	else  if ("node_local"=first)&(""'=regindex) set mnemonicandreg="NLREG:"_regindex
	else  if ("node_local"=first)&(""=regindex) set mnemonicandreg="NLREPL"
	else  if "repl_inst_hdr"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="RIHREPL"
	else  if "recvpool_ctl_struct"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="RPCREPL"
	else  if "upd_helper_ctl_struct"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="UHCREPL"
	else  if "upd_proc_local_struct"=first do:""'=regindex error("NOPARM",first) set mnemonicandreg="UPLREPL"
	else  do error("UNSUPSTRUCT",first)
	do
	.	new $zgbldir
	.	set $zgbldir=$ztrnlnm("gtm_dist")_"/gtmhelp.gld"
	.	set typeindex=$get(^gtmtypfldindx(first,rest))
	.	do:0=+typeindex error("INVALID",first,rest)
	.	set offset=^gtmtypes(first,typeindex,"off")
	.	set length=^gtmtypes(first,typeindex,"len")
	.	set type=^gtmtypes(first,typeindex,"type")
	if $get(format)="" do
	.	if (type="unsigned-char")&(1=length) set format="U"
	.	else  if (type="char")&(1=length) set format="I"
	.	else  if type["char" set format="C"
	.	else  if (type["addr")!(type["ptr")!(type="void") set format="X"
	.	else  if (type["uint")!(type["unsigned") set format="U"
	.	else  set format="I"
	set $etrap=etrap
	quit $zpeek(mnemonicandreg,offset,length,format)

; Raises an error with given arguments
error(err,first,args)
	new i,x
	set str=$text(@("ERRPBN"_err)),x="x="_$piece(str,";",3),@x,str=$piece(str,";",2)_","
	if ("PARMREQ"=err)!("INVALID"=err) set args=""""_first_""":"""_args_""""
	else  if ("NOPARM"=err)!("UNSUPSTRUCT"=err) set args=""""_first_""""
	else  set args=""""""
	set $etrap="if $zstatus[""UNKNOWN"" set $zstatus=""%GTM-E-""_str_x zgoto land"	; in case of older versions
	xecute "zmessage "_$translate(str,",",":")_args	; XECUTE because indirection exploded in older versions
	zgoto land

; Prints all $ZPEEK() acceptable fields
LISTALL
	do listiterate()
	quit

; Populates output with type and length information indexed by $ZPEEK() acceptable fields
; e.g. output("gd_region.jnl_file_name")="unsigned-char,256"
LIST(output)
	do listiterate(.output)
	quit

; Iterate through names of the structures defined in ^gtmtypes and execute given command for each one
listiterate(out)
	new $zgbldir,fieldname,i,j,struct,write
	set $zgbldir=$ztrnlnm("gtm_dist")_"/gtmhelp.gld"
	set write=100>$zdata(out)
	for i=1:1 set struct=$piece($text(struct+i),";",2) quit:""=struct  do
	. for j=1:1  set fieldname=$get(^gtmtypes(struct,j,"name")) quit:""=fieldname  do
	. . if 'write set out(fieldname)=^gtmtypes(struct,j,"type")_","_^gtmtypes(struct,j,"len")
	. . else  write fieldname,!
	quit
; the below error definitions derived from merrors.msg are relatively complete so older version where they weren't defined get info
ERRPBNPARMREQ		;150383746;"A first parameter value "_first_" requires a second parameter specified containing "_args
ERRPBNNOPARM		;150383754;"First parameter "_first_" does not support a second parameter"
ERRPBNUNSUPSTRUCT	;150383762;"$ZPEEK() does not support structure "_first
ERRPBNINVALID		;150383770;first_" does not have a field named "_args
ERRPBNNOFIELD		;150383778;"%ZPEEKBYNAME() requires a field.item in its first parameter"
struct	;  listed below, in alphabetical order, structures currently supported by ^%PEEKBYNAME
	;gd_region
	;gtmrecv_local_struct
	;gtmsource_local_struct
	;gtmsrc_lcl
	;jnl_buffer
	;jnl_private_control
	;jnlpool_ctl_struct
	;node_local
	;recvpool_ctl_struct
	;repl_inst_hdr
	;sgmnt_addrs
	;sgmnt_data
	;upd_helper_ctl_struct
	;upd_proc_local_struct