PeterJ 2010-11-08 01:57

/* -----------------------------------------------------------------------------------
 * DEFINE: Define Structure, 
 * PUT:    Build Record using Variables
 * GET:    Extract Variables from Record 
 * -----------------------------------------------------------------------------------
 */
structure: PROCEDURE EXPOSE(allitems)  
USE ARG mode,strdef.,inrec
record=''
IF mode='GET' THEN INTERPRET strdef._get
ELSE IF mode='PUT' THEN DO 
   INTERPRET strdef._put
   RETURN record
END 
ELSE IF mode='DEFINE' THEN DO 
   fget=''
   fput='record=""'
   nextoffset=1
   reloffsetp=0
   reloffsetg=0
   noffset=1
   DO i=1 TO strdef.0
      PARSE VALUE TRANSLATE(strdef.i) WITH variable type len offset
      CALL fetchparms
      IF offset="" THEN offset=nextoffset          /* calculate offset */
      CALL prepareput
      CALL prepareget
      CALL exposeitem
      IF reloffsetp=0 THEN nextoffset=offset+len   /* calculate offset */
   END
/* Save GET/PUT definitions in stem variable, contained in structure definition */
   strdef._get=SUBSTR(fget,2)
   strdef._put=fput 
END
RETURN 0
/* -----------------------------------------------------------------------------------
 * Fetch single items from structure item definitio 
 * -----------------------------------------------------------------------------------
 */
fetchparms:
variable=STRIP(variable)
type=STRIP(type)
offset=STRIP(offset)
len=STRIP(len)
RETURN
/* -----------------------------------------------------------------------------------
 * create statements to extract variables from Record (executed later by Interpret) 
 * -----------------------------------------------------------------------------------
 */
prepareget:
IF reloffsetg=1 THEN offset='noffset'
IF type="VAR" THEN DO
   fget=fget';varlen=C2D(substr(inrec,'offset',2),2)' 
   fget=fget";"variable"=substr(inrec,"offset"+2,varlen);noffset="offset"+varlen+2"
   reloffsetg=1
END
ELSE DO 
   fget=fget";"variable"=substr(inrec,"offset","len")"
   IF type="BIN" THEN fget=fget';'variable"=C2D("variable","len")"
   ELSE IF type="DEC" THEN fget=fget';'variable"=UnPack("variable")"
   IF reloffsetg=1 THEN fget=fget';noffset=noffset+'len
END
RETURN 
/* -----------------------------------------------------------------------------------
 * create statements to push variables into Record (executed later by Interpret) 
 * -----------------------------------------------------------------------------------
 */
prepareput:
pvar=variable
IF reloffsetp=1 THEN offset='noffset'
IF type="VAR" THEN DO 
   fput=fput';vlen=length('pvar');vlenvar=D2C(vlen,2)'pvar 
   fput=fput";record=overlay(vlenvar,record,"offset",vlen+2);noffset="offset"+vlen+2"
   reloffsetp=1
END
ELSE DO 
   IF type="NUM" THEN pvar="right("variable","len",0)"
   IF type="BIN" THEN pvar="D2C("variable","len")"
   IF type="DEC" THEN pvar="PACK("variable","len+len")"  /* pack len means digit = 2* byte len */
   fput=fput";record=overlay("pvar",record,"offset","len")"
   IF reloffsetp=1 THEN fput=fput';noffset=noffset+'len
END
RETURN
/* -----------------------------------------------------------------------------------
 * Expose all Variables from structure
 * -----------------------------------------------------------------------------------
 */
exposeitem:
IF EXISTS("AllItems")=0 THEN allitems=""
allitems=allitems||variable" "
RETURN
/* --------------------------------------------------------------        
 *   UNPACK(packed_number) 
 *      packed_number : is decimal packed number 
 *      return_value  : rexx compatible integer value
 * --------------------------------------------------------------        
 */                                                                     
unpack: PROCEDURE EXPOSE TRACE                                          
PARSE ARG packno                                                        
/* CONVERT PACKED DATA TO HEX AND SPLIT */                              
chrstr=C2X(packno)                                                      
decno=LEFT(chrstr,LENGTH(chrstr)-1)                                     
SIGN=RIGHT(chrstr,1)                                                    
IF VERIFY(SIGN,"ABCDEF" )>0 | ,
   VERIFY(decno,"0123456789" )>0 THEN RETURN ""                                
/* CHECK SIGN */               
IF  TRANSLATE(SIGN,,"BD")=" " THEN RETURN -decno                                 
RETURN decno                                                            
/* -------------------------------------------------------------        
 *   PACK(number,<pack_length>) 
 *      packed_number : is rexx compatible integer value 
 *      pack_length   : length of returned packed number
 *                        (defaults to minimum required field) 
 * -------------------------------------------------------------        
 */                                                                     
pack: PROCEDURE EXPOSE TRACE                                            
ARG decno,declen                                                        
IF decno<0 THEN SIGN='D' 
ELSE SIGN='C'                                                        
number=SPACE(TRANSLATE(decno,,'+-.')sign,0)                             
minlen=LENGTH(number)+length(number)//2     
IF declen="" THEN declen=minlen                            
IF minlen>declen THEN RETURN ""                                               
number=X2C(RIGHT(number,declen,'0'))     
RETURN number   

PeterJ 2010-11-08 01:57