QECCVTEC - Convert edit code mask

Convert edit code mask ** Program . . : CBX109S ** Description : Get file field value by key ** ** Program summary ** --------------- ** Object - User space APIs: ** QUSCRTUS Create user space Creates a user space in either ** user domain or system domain. ** Only user domain user spaces are ** accessible by the user space APIs. ** ** QUSDLTUS Delete user space Deletes the user space specified. ** ** QUSPTRUS Retrieve pointer to The address of the first byte ** user space of the storage allocated by the ** user space requested is returned. ** ** Database and file APIs: ** QUSLFLD List fields Lists the fields of the specified ** file record format to user space. ** ** The list includes information ** about each field's attributes and ** record buffer position. ** ** Work management API: ** QUSRJOBI Retrieve job Retrieves specific information ** information about a specific job, covering ** all attributes and other state ** and runtime related information. ** ** Edit function API: ** QECCVTEC Convert edit code Converts an edit code into an ** mask edit mask, which is a set of ** instructions used by the edit ** function to format a numeric ** value into a character string. ** ** MI builtins: ** _LBEDIT Late bound edit Transforms a numeric value from ** its internal format to character ** form, using the provided edit ** mask. Late bound here refers to ** the source value location not ** having to be provided until ** runtime. ** ** ** _MEMMOVE Copy memory Copies a string from one pointer ** specified location to another. ** ** C library functions: ** _Ropen Open record file Opens the record file specified ** as defined by the keywords in the ** mode parameter. If the file does ** not exist it will not be created. ** ** The mode parameter specifies the ** type of file access as well as ** optional parameters to control ** f.x. whether the file is read in ** arrival or keyed order. ** ** The *LIBL & *CURLIB special values ** are supported for the library ** name and an optional member name ** is possible to specify in the ** format library/file(member). ** ** _Rclose Close record file This API closes the previously ** opened record file identified by ** the file pointer parameter. ** ** Storage allocated is freed and ** all buffers are flushed. ** ** _Rreadk Read by key Reads a record in a keyed file ** matching the key value parameter. ** This key value can be partial. ** The record is locked unless the ** No_Lock option is set. ** ** ** Service program procedures: ** GetFldVal Get field value Based on a file name, field name ** and key value, the corresponding ** field value is returned in left ** adjusted character format. ** ** The library list is searched to ** locate the file specified. ** ** This function can be called as ** a single request performing all ** involved steps at once. Or - if ** repeated retrievals from the same ** file are required - as a session ** performing the initialization and ** termination process only once. ** ** If an error occurs in the process ** the resulting error message id is ** returned as the field value. ** ** LstFld List fields Lists to the specified user space ** a list of the specified file's ** fields, including name, data type ** and length. ** ** Chain Read record by key Performs the actual keyed access ** to the file identified by the ** file pointer passed and returns, ** if a match is found, the record ** buffer retrieved. ** ** RtvFld Retrieve field The buffer offset, data type and ** field length of the field name ** specified is retrieved from the ** user space field list. ** ** Based on these field attributes ** the field's value is extracted ** and, if necessary, converted to ** character format and eventually ** returned to the caller. ** ** The record buffer is available ** to this procedure by means of a ** global variable. ** ** EditC Edit by edit code Converts the specified buffer ** location containing a numeric ** value in internal format to a ** readable character format as ** defined by the specified edit ** code. ** ** ApyDecFmt Apply decimal Applies the current job's decimal ** format format to binary fields having ** decimal positions. ** ** ** Programmer's notes: ** This API example's intention is to demonstrate the ability to parse ** an externally defined record buffer using various APIs, MI builtins ** and C library functions. ** ** The flexibility achieved by the parameterized field value level ** access to an externally defined file could be further extended to ** enable the reverse functionality. The _CVTEFN and _LBCPYNV(R) MI ** builtins offer functionality that enables you to update a numeric ** field in a record buffer, based on a character representation of a ** numeric value, respectively another buffer location containing a ** numeric value. ** ** This way many types of file and data exchanges could be soft coded ** throughout the whole exchange process. Note however, that updating ** production data at the buffer level requires careful design and a ** high level of precaution - the above lines only intents to point ** out the possibility - in case that need should arise at some point. ** ** ** Compile options required: ** CrtRpgMod CBX109S + ** DbgView( *LIST ) ** ** CrtSrvPgm CBX109S + ** Module( CBX109S ) + ** Export( *ALL ) + ** ActGrp( QSRVPGM ) ** ** **-- Header specifications: --------------------------------------------** H NoMain BndDir( 'QC2LE' ) Option( *SrcStmt ) **-- System information: -----------------------------------------------** D PgmSts SDs D PsPgmNam *Proc D PsMsgId 7a Overlay( PgmSts: 40 ) **-- Api error data structure: -----------------------------------------** D ApiError Ds D AeBytPro 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 Inz D AeMsgId 7a D 1a D AeMsgDta 128a **-- I/O feedback structure & constants: -------------------------------** D RIOFB Ds Based( pRIOFB ) D pKey * D pSysParm * D IoRcdRrn 10u 0 D IoNbrBytRw 10i 0 D IoBlkCnt 5i 0 D IoBlkFllBy 1a D IoBitFld 1a D IoRsv 20a ** D Key_Lt c x'09000100' D Key_Le c x'0A000100' D Key_Eq c x'0B000100' D Key_Eq_N c x'0B000101' D Key_Ge c x'0C000100' D Key_Gt c x'0D000100' ** D No_Lock c x'00000001' **-- Edit template & constants: ----------------------------------------** D DPA_Template_T Ds D SclTyp 1a D SclLen 5i 0 D DecPos 3i 0 Overlay( SclLen: 1 ) D DecLen 3i 0 Overlay( SclLen: 2 ) D Rsv 10i 0 Inz ** D T_SIGNED c x'00' D T_FLOAT c x'01' D T_ZONED c x'02' D T_PACKED c x'03' D T_UNSIGNED c x'0A' **-- Global variables: -------------------------------------------------** D RcdBuf s 4096a D pRFILE s * D rc s 10i 0 **-- Global constants: -------------------------------------------------** D Null c '' D UsrSpc c 'DBFLST QTEMP' **-- Create user space: -------------------------------------------------** D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' ) D CsSpcNamQ 20a Const D C***tAtr 10a Const D CsInzSiz 10i 0 Const D CsInzVal 1a Const D CsPubAut 10a Const D CsText 50a Const **-- Optional 1: D CsReplace 10a Const Options( *NoPass ) D CsError 32767a Options( *NoPass: *VarSize ) **-- Optional 2: D CsDomain 10a Const Options( *NoPass ) **-- Retrieve pointer to user space: ------------------------------------** D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' ) D RpSpcNamQ 20a Const D RpPointer * D RpError 32767a Options( *NoPass: *VarSize ) **-- Delete user space: ------------------------------------------------** D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' ) D DsSpcNamQ 20a Const D DsError 32767a Options( *VarSize ) **-- List fields to user space: ----------------------------------------** D LstFldSpc Pr ExtPgm( 'QUSLFLD' ) D LfSpcNamQ 20a Const D LfFmtNam 8a Const D LfFilNamQual 20a Const D LfRcdFmtNam 10a Const D LfOvrPrc 1a Const D LfError 32767a Options( *NoPass: *VarSize ) **-- Convert edit code to mask: ----------------------------------------** D CvtCdeMsk Pr ExtPgm( 'QECCVTEC' ) D CcEdtMsk 256a D CcEdtMskLen 10i 0 D CcRcvVarLen 10i 0 D CcZroFilChr 1a D CcEdtCde 1a Const D CcCcyInd 1a Const D CcSrcVarPrc 10i 0 Const D CcSrcVarDec 10i 0 Const D CcError 32767a Options( *VarSize ) **-- Retrieve job information: -----------------------------------------** D RtvJobInf Pr ExtPgm( 'QUSRJOBI' ) D RiRcvVar 32767a Options( *VarSize ) D RiRcvVarLen 10i 0 Const D RiFmtNam 8a Const D RiJobNamQ 26a Const D RiJobIntId 16a Const **-- Optional 1: D RiError 32767a Options( *NoPass: *VarSize ) **-- Optional 2: D RiRstStc 1a Options( *NoPass ) **-- Open file: --------------------------------------------------------** D Ropen Pr * ExtProc( '_Ropen' ) D pRFile * Value Options( *String ) D pMode * Value Options( *String ) **-- Close file: -------------------------------------------------------** D Rclose Pr 10i 0 ExtProc( '_Rclose' ) D pRFile * Value **-- Read by key: ------------------------------------------------------** D Rreadk Pr * ExtProc( '_Rreadk' ) D pRFile * Value D pBuffer * Value D BufLength 10u 0 Value D Options 10i 0 Value D pKey * Value D KeyLength 10u 0 Value **-- Copy memory: ------------------------------------------------------** D MemCpy Pr * ExtProc( '_MEMMOVE' ) D pOutMem * Value D pInpMem * Value D iMemSiz 10u 0 Value **-- Edit function: ----------------------------------------------------** D Edit Pr ExtProc( '_LBEDIT' ) D RcvVar * Value D RcvVarLen 10u 0 Const D SrcVar * Value D SrcVarAtr Const Like( DPA_Template_T ) D EdtMsk 256a Const D EdtMskLen 10u 0 Const **-- Get field value: --------------------------------------------------** D GetFldVal Pr 1024a Varying D PxRqsTyp 10i 0 Const D PxFilNam 10a Const Options( *NoPass ) D PxFldNam 10a Const Options( *NoPass ) D PxKey 256a Const Varying Options( *NoPass ) **-- List fields: ------------------------------------------------------** D LstFld Pr 7a Varying D PxUsrSpc 20a Const D PxFilNam 10a Const **-- Read file by key: -------------------------------------------------** D Chain Pr 10240a Varying D PxFilPtr * Const D PxKeyVal 256a Const **-- Retrieve field: ---------------------------------------------------** D RtvFld Pr 1024a Varying D PxUsrSpc 20a Const D PxFldNam 10a Const **-- Edit code: --------------------------------------------------------** D EditC Pr 256a Varying D PxDecVar * Value D PxDecTyp 1a Const D PxDecDig 5u 0 Const D PxDecPos 5u 0 Const D PxEdtCde 1a Const **-- Apply decimal format: ---------------------------------------------** D ApyDecFmt Pr 32a Varying D PxInpStr 32a Value Varying D PxDecPos 5u 0 Const **-- Get field value: --------------------------------------------------** P GetFldVal B Export D Pi 1024a Varying D PxRqsTyp 10i 0 Const D PxFilNam 10a Const Options( *NoPass ) D PxFldNam 10a Const Options( *NoPass ) D PxKey 256a Const Varying Options( *NoPass ) **-- Local variables: D FldVal s 1024a Varying **-- Get field value: --------------------------------------------------** ** C Eval FldVal = Null ** C If %Parms >= 2 C C If PxRqsTyp = 0 Or C PxRqsTyp = 1 ** C CallP CrtUsrSpc( UsrSpc C : *Blanks C : 65535 C : x'00' C : '*CHANGE' C : *Blanks C : '*YES' C : ApiError C ) ** C If AeBytAvl > *Zero C Eval FldVal = AeMsgId ** C Else C Eval FldVal = LstFld( UsrSpc C : PxFilNam C ) ** C Monitor C Eval pRFILE = Ropen( PxFilNam C : 'rr, nullcap=Y' C ) ** C On-Error C Eval FldVal = PsMsgId C EndMon C EndIf ** C EndIf C EndIf ** C If %Parms = 4 And C FldVal = Null And C pRFILE > *Null C C If PxRqsTyp = 0 Or C PxRqsTyp = 2 ** C Eval RcdBuf = Chain( pRFILE: PxKey ) ** C If RcdBuf <> Null ** C Eval FldVal = RtvFld( UsrSpc C : PxFldNam C ) C EndIf ** C EndIf C EndIf ** C If %Parms >= 1 C C If PxRqsTyp = 0 Or C PxRqsTyp = 3 ** C Eval rc = Rclose( pRFILE ) ** C CallP DltUsrSpc( UsrSpc C : ApiError C ) ** C EndIf C EndIf ** C Return FldVal ** P GetFldVal E **-- List fields: ------------------------------------------------------** P LstFld B Export D Pi 7a Varying D PxUsrSpc 20a Const D PxFilNam 10a Const **-- List fields: ------------------------------------------------------** ** C CallP LstFldSpc( PxUsrSpc C : 'FLDL0100' C : PxFilNam + '*LIBL' C : '*FIRST' C : '0' C : ApiError C ) ** C If AeBytAvl = *Zero C Return Null ** C Else C Return AeMsgId C EndIf ** P LstFld E **-- Read file by key: -------------------------------------------------** P Chain B Export D Pi 10240a Varying D PxFilPtr * Const D PxKeyVal 256a Const ** D StrBuf s 10240a D RtnBuf s 10240a Varying D KeyFld s 256a **-- Chain: ------------------------------------------------------------** ** C Eval KeyFld = PxKeyVal ** C Eval pRIOFB = Rreadk( PxFilPtr C : %Addr( StrBuf ) C : %Size( StrBuf ) C : Key_Eq_N C : %Addr( KeyFld ) C : %Len( %TrimR( KeyFld )) C ) ** C If IoNbrBytRw > 0 C Eval RtnBuf = %SubSt( StrBuf: 1: IoNbrBytRw ) C EndIf ** C Return RtnBuf ** P Chain E **-- Retrieve field: ---------------------------------------------------** P RtvFld B Export D Pi 1024a Varying D PxUsrSpc 20a Const D PxFldNam 10a Const **-- Local variables: D FldVal s 1024a D Idx s 10u 0 **-- API format FLDL0100: D FldLst100 Ds Based( pLstEnt ) D F1FldNam 10a D F1DtaTyp 1a D F1DtaUse 1a D F1OutBufPos 10i 0 D F1InpBufPos 10i 0 D F1Len 10i 0 D F1Digits 10i 0 D F1DecPos 10i 0 D F1TxtDsc 50a D F1EdtCod 2a D F1EdtWrdLen 10i 0 D F1EdtWrd 64a D F1ColHdg1 20a D F1ColHdg2 20a D F1ColHdg3 20a D F1IntFldNam 10a D F1AltFldNam 30a D F1AltFldNamLn 10i 0 D F1NbrChrDbcs 10i 0 D F1AlwNull 1a D F1HstVarInd 1a D F1DatTimFmt 4a D F1DatTimSep 1a D F1VarFldLenIn 1a D F1TxtDscCcsId 10i 0 D F1DtaCcsId 10i 0 D F1ColHdgCcsId 10i 0 D F1EdtWrdCcsId 10i 0 D F1Ucs2DspFldL 10i 0 **-- API header information: D HdrInf Ds Based( pHdrInf ) D FlFilNamU 10a D FlFilLibU 10a D FlFilTyp 10a D FlRcdFmtNamU 10a D FlRcdLen 10i 0 D FlRcdFmtId 13a D FlRcdTxtDsc 50a D 1a D FlRcdTxtCcsId 10i 0 D FlVarLenFldIn 1a D FlGphFldInd 1a D FlDatTimFldIn 1a D FlNulCapFldIn 1a **-- User space generic header: D UsrSpc Ds Based( pUsrSpc ) D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 ) D UsOfsLst 10i 0 Overlay( UsrSpc: 125 ) D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 ) D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 ) **-- User space pointers: D pUsrSpc s * Inz( *Null ) D pHdrInf s * Inz( *Null ) D pLstEnt s * Inz( *Null ) **-- Retrieve field: ---------------------------------------------------** ** C CallP RtvPtrSpc( PxUsrSpc: pUsrSpc ) ** C Eval pHdrInf = pUsrSpc + UsOfsHdr C Eval pLstEnt = pUsrSpc + UsOfsLst ** C For Idx = 1 To UsNumLstEnt ** C If F1FldNam = PxFldNam ** C Select C When F1DtaTyp = 'A' Or C F1DtaTyp = 'L' Or C F1DtaTyp = 'T' Or C F1DtaTyp = 'Z' ** C CallP MemCpy( %Addr( FldVal ) C : %Addr( RcdBuf ) + C F1InpBufPos - 1 C : F1Len C ) ** C When F1DtaTyp = 'P' Or C F1DtaTyp = 'Z' Or C F1DtaTyp = 'B' ** C Eval FldVal = EditC( %Addr( RcdBuf ) + C F1InpBufPos - 1 C : F1DtaTyp C : F1Digits C : F1DecPos C : 'P' C ) ** C EndSl ** C Leave C EndIf ** C If Idx < UsNumLstEnt C Eval pLstEnt = pLstEnt + UsSizLstEnt C EndIf C EndFor ** C Return %TrimR( FldVal ) ** P RtvFld E **-- Edit code: --------------------------------------------------------** P EditC B Export D Pi 256a Varying D PxDecVar * Value D PxDecTyp 1a Const D PxDecDig 5u 0 Const D PxDecPos 5u 0 Const D PxEdtCde 1a Const **-- Local variables & constants: D EdtMsk s 256a D EdtMskLen s 10i 0 D RcvVar s 256a D RcvVarLen s 10i 0 D ZroFilChr s 1a D DecDig s 10u 0 ** **-- Edit: -------------------------------------------------------------** ** C Select C When PxDecTyp = 'P' Or C PxDecTyp = 'Z' ** C If PxDecTyp = 'P' C Eval SclTyp = T_PACKED C Else C Eval SclTyp = T_ZONED C EndIf ** C Eval DecDig = PxDecDig C Eval DecPos = PxDecPos C Eval DecLen = PxDecDig ** C When PxDecTyp = 'B' ** C Eval SclTyp = T_SIGNED ** C Eval DecDig = PxDecDig C Eval DecPos = *Zero ** C If DecDig > 5 C Eval DecDig = 10 C Eval DecLen = 4 C Else C Eval DecDig = 5 C Eval DecLen = 2 C EndIf C EndSl ** C CallP CvtCdeMsk( EdtMsk C : EdtMskLen C : RcvVarLen C : ZroFilChr C : PxEdtCde C : ' ' C : DecDig C : DecPos C : ApiError C ) ** C CallP(e) Edit( %Addr( RcvVar ) C : RcvVarLen C : PxDecVar C : DPA_Template_T C : EdtMsk C : EdtMskLen C ) ** C If %Error C Return Null ** C ElseIf PxDecTyp = 'B' And C PxDecPos > *Zero ** C Return ApyDecFmt( %SubSt( RcvVar: 1: RcvVarLen ) C : PxDecPos C ) ** C Else C Return %TrimL( %SubSt( RcvVar: 1: RcvVarLen )) C EndIf ** P EditC E **-- Apply decimal format: ---------------------------------------------** P ApyDecFmt B D Pi 32a Varying D PxInpStr 32a Value Varying D PxDecPos 5u 0 Const **-- Local variables: D ZroOfs s 5u 0 D DecOfs s 5u 0 **-- Job info format JOBI0400: D J4RcvDta Ds D J4BytRtn 10i 0 D J4BytAvl 10i 0 D J4JobNam 10a D J4UsrNam 10a D J4JobNbr 6a D J4DecFmt 1a Overlay( J4RcvDta: 457 ) ** C CallP RtvJobInf( J4RcvDta C : %Size( J4RcvDta ) C : 'JOBI0400' C : '*' C : *Blank C : ApiError C ) ** C If AeBytAvl > *Zero C Return PxInpStr C Else ** C If J4DecFmt = 'J' C Eval ZroOfs = %Len( PxInpStr ) - PxDecPos C Eval DecOfs = ZroOfs + 1 C Else C Eval ZroOfs = %Len( PxInpStr ) - PxDecPos + 1 C Eval DecOfs = ZroOfs C EndIf ** C Eval PxInpStr = %Xlate( ' ' C : '0' C : PxInpStr C : ZroOfs C ) C ** C If J4DecFmt = ' ' C Return %Replace( '.' C : PxInpStr C : DecOfs C : 0 C ) ** C Else C Return %Replace( ',' C : PxInpStr C : DecOfs C : 0 C ) C EndIf C EndIf ** P ApyDecFmt E

The calling program ** Program . . : CBX109T ** Description : Get file field value by key - Test ** ** Program directions ** ------------------ ** ** This test program retrieves field values from the TCP/IP host table ** which is stored in a physical file named QATOCHOST in QUSRSYS. ** ** Go CFGTCP option 10 allow you to examine the current entries in this ** table. If you want, or if required, please change the key value from ** '127.0.0.1' to another existing entry in the table. Please also ** check that you have sufficient authority to the table prior to ** running this test program. ** ** Another option would be to replace the file name, field name and key ** value specified in the example below to values of your own choice. ** ** This test program presents the retrieved field values using the DSPLY ** facility. You could also simply start a debug session against this ** program and step through the code lines, to watch the process as it ** unfolds. ** ** When the debug session is positioned on a GetFldVal() procedure ** statement you can use F22 to step into the subprocedure and examine ** the statements executed there. The F10 step instruction also applies ** while in the subprocedure. ** ** ** Compile options required: ** CrtRpgMod CBX109T + ** DbgView( *LIST ) ** ** CrtPgm CBX109T + ** Module( CBX109T ) + ** BndSrvPgm( CBX109S ) + ** ActGrp( QILE ) ** ** **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) **-- Global definitions: -----------------------------------------------** D FldVal s 1024a Varying D DspVal s 42a ** D SngRqs c 0 D InzRqs c 1 D RunRqs c 2 D TrmRqs c 3 **-- Get field value: --------------------------------------------------** D GetFldVal Pr 1024a Varying D PxRqsTyp 10i 0 Const D PxFilNam 10a Const Options( *NoPass ) D PxFldNam 10a Const Options( *NoPass ) D PxKey 256a Const Varying Options( *NoPass ) ** **-- Mainline: ---------------------------------------------------------** ** C Eval FldVal = GetFldVal( SngRqs C : 'QATOCHOST' C : 'HOSTNME1' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'HOSTNME1 =' Dsply DspVal ** C Eval FldVal = GetFldVal( InzRqs C : 'QATOCHOST' C ) ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'HOSTNME1' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'HOSTNME1 =' Dsply DspVal ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'IPINTGER' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'IPINTGER =' Dsply DspVal ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'TXTDESC' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'TXTDESC =' Dsply DspVal ** C Eval FldVal = GetFldVal( TrmRqs ) ** C Return ** Thanks to Carsten Flensburg