QUSLFLD List Fields
QUSCRTUS Create user space
QUSDLTUS Delete user space
QUSPTRUS Retrieve pointer to user space
**
** Description : Find database field containing scan string
**
** 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.
**
** National language support API:
** QlgConvertCase Convert case Converts a character string to
** upper or lower case based on a
** coded character set identifier
** (CCSID) rather than a table.
**
** The CCSID support makes the API
** very flexible to use, but based
** on experience a certain overhead
** is incurred in this process.
**
** 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.
**
** _Rreadf Read first record Reads the first record in the
** access pass specified by file
** pointer in either arrival or
** keyed order.
**
** _Rreadn Read next record Reads the next record in the
** access pass specified by file
** pointer in either arrival or
** keyed order.
**
**
** Sequence of events:
** 1. A translation table is setup using the convert case API to
** ensure correct code page translation and at the same time - by
** using at table driven translation - avoid the overhead related
** to repeatedly calling the conversion API.
**
** 2. A user space is created and the list of the requested file's
** fields is loaded to the user space.
**
** 3. The requested file is opened for sequential and blocked read
** only.
**
** 4. The file records are read one by one into a buffer string.
**
** 5. The retrieved record buffer is processed one field at a time,
** scanning every alfa field for the scan string - with or without
** case sensitivity as requested.
**
** 6. For each field containing the scan string a line is printed.
**
** 7. At end of file the file is closed, the user space deleted and
** the program is terminated.
**
**
** Programmer's notes:
** The manual specifies that the record block size - if blocking is
** requested - will be optimized by the system. Unfortunately the
** system still seems to regard the optimum block size on the iSeries
** to be 4K - even though it for RISC systems is 128K.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX103 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX103 )
** Module( CBX103 )
**
**-- Header specifications: --------------------------------------------**
H BndDir( 'QC2LE' ) Option( *SrcStmt ) DatEdit( *MDY/ )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global variables: -------------------------------------------------**
D pRFILE s *
D rc s 10i 0
D Idx s 10i 0
D StrBuf s 10240a
D RtnBuf s 10240a
D FldVal s 1024a Varying
D FldVal40 s 40a
D ScnVal s 1024a Varying
D ScnArg s 32a Varying
D ScnPos s 4s 0
**
D Time s 6s 0
D NbrRcds s 10u 0
**-- Xlate table variables: --------------------------------------------**
D Cvt Ds
D CvtNum 3u 0 Dim( 255 )
D CvtAlf 1a Dim( 255 ) Overlay( Cvt )
**
D Hi s 255a Varying
D Lo s 255a Varying
**-- Global constants: -------------------------------------------------**
D UsrSpcQ c 'DBFLST QTEMP'
D No_Lock c x'00000001'
**-- 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: -------------------------------------------**
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
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- 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 )
**-- 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
**-- API format FLDL0100: ----------------------------------------------**
D FldLst0100 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
**-- Convert case parameters & constants: ------------------------------**
D CcRqsCtlBlk Ds
D RcRqsType 10i 0 Inz( CvtByCcsId )
D RcCCSID 10i 0 Inz( JobCcsId )
D RcCaseRqs 10i 0 Inz
D 10a Inz( *Allx'00')
**
D CvtByCcsId c 1
D JobCcsId c 0
D Lower c 1
D Upper c 0
**-- List fields: ------------------------------------------------------**
D LstFld Pr *
D PxUsrSpc 20a Const
D PxFilNam 10a Const
D PxLibNam 10a Const
**-- To upper case: ----------------------------------------------------**
D ToUpper Pr 1024a Varying
D InpStr 1024a Const Varying
**-- To lower case: ----------------------------------------------------**
D ToLower Pr 1024a Varying
D InpStr 1024a Const Varying
**-- Open file: --------------------------------------------------------**
D Ropen Pr * ExtProc( '_Ropen' )
D pRFile * Value Options( *String )
D pMode * Value Options( *String )
D pOptParm * Value Options( *String: *NoPass )
**-- Close file: -------------------------------------------------------**
D Rclose Pr 10i 0 ExtProc( '_Rclose' )
D pRFile * Value
**-- Read first record: ------------------------------------------------**
D Rreadf Pr * ExtProc( '_Rreadf' )
D pRFile * Value
D pBuffer * Value
D BufLength 10u 0 Value
D Options 10i 0 Value
**-- Read next record: -------------------------------------------------**
D Rreadn Pr * ExtProc( '_Rreadn' )
D pRFile * Value
D pBuffer * Value
D BufLength 10u 0 Value
D Options 10i 0 Value
**-- 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 )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Convert case: -----------------------------------------------------**
D CvtCase Pr ExtProc( 'QlgConvertCase' )
D CcRqsBlk 22a Const
D CcInpDta 32767a Const Options( *VarSize )
D CcOutDta 32767a Options( *VarSize )
D CcDtaLen 10i 0 Const
D CcError 32767a Options( *VarSize )
**-- Program parameters: -----------------------------------------------**
D PxFilNam s 10a
D PxLibNam s 10a
D PxScnArg s 32a
D PxCasSns s 1a
**
C *Entry Plist
C Parm PxFilNam
C Parm PxLibNam
C Parm PxScnArg
C Parm PxCasSns
**
**-- Mainline: ---------------------------------------------------------**
**
C ExSr InzPgm
**
C If PxScnArg > *Blanks
**
C Eval pUsrSpc = LstFld( UsrSpcQ
C : PxFilNam
C : PxLibNam
C )
**
C If pUsrSpc <> *Null
**
C Eval pRFILE = Ropen( %Trim( PxLibNam ) +
C '/' +
C %Trim( PxFilNam )
C : 'rr, arrseq=Y, ' +
C 'blkrcd=Y'
C )
C
C If pRFILE <> *Null
**
C Eval pRIOFB = Rreadf( pRFILE
C : %Addr( StrBuf )
C : %Size( StrBuf )
C : No_Lock
C )
**
C DoW IoNbrBytRw > 0
**
C ExSr PrcRcd
**
C Eval pRIOFB = Rreadn( pRFILE
C : %Addr( StrBuf )
C : %Size( StrBuf )
C : No_Lock
C )
**
C EndDo
**
C Eval rc = Rclose( pRFILE )
**
C EndIf
C EndIf
C EndIf
**
C ExSr TrmPgm
**
**-- Process record: ---------------------------------------------------**
C PrcRcd BegSr
**
C Eval RtnBuf = %SubSt( StrBuf: 1: IoNbrBytRw )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 To UsNumLstEnt
**
C If F1DtaTyp = 'A'
**
C Eval FldVal = %SubSt( RtnBuf
C : F1InpBufPos
C : F1Len
C )
**
C If PxCasSns = 'Y'
C Eval ScnVal = %Xlate( Lo: Hi: FldVal )
C Else
C Eval ScnVal = FldVal
C EndIf
**
C Eval ScnPos = %Scan( ScnArg: ScnVal )
C If ScnPos > *Zero
**
C ExSr WrtLstLin
C EndIf
C EndIf
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Write list line: --------------------------------------------------**
C WrtLstLin BegSr
**
C Eval FldVal40 = FldVal
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C EndIf
**
C Eval NbrRcds = NbrRcds + 1
C Except Detail
**
C EndSr
**-- Initialize program: -----------------------------------------------**
C InzPgm BegSr
**
C ExSr InzXltTbl
**
C If PxCasSns = 'Y'
C Eval ScnArg = %TrimR( PxScnArg )
C Eval ScnArg = %Xlate( Lo: Hi: ScnArg )
**
C Else
C Eval ScnArg = %TrimR( PxScnArg )
C EndIf
**
C Time Time
C Except Header
**
C CallP CrtUsrSpc( UsrSpcQ
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C EndSr
**-- Initialize translation table: -------------------------------------**
C InzXltTbl BegSr
**
**-- Fill conversion table with displayable (hex 40-hex FE) and
**-- non-duplicate codepoints only:
**
C For Idx = 40 to %Elem( CvtNum )
C Eval CvtNum(Idx) = Idx
C EndFor
**
C Eval Cvt = ToUpper( Cvt )
C SortA CvtAlf
**
C For Idx = 40 to %Elem( CvtAlf )
**
C If CvtAlf(Idx) > CvtAlf(Idx-1)
C Eval Hi = Hi + CvtAlf(Idx)
C EndIf
C EndFor
**
C Eval Lo = ToLower( Hi )
**
C EndSr
**-- Terminate program: ------------------------------------------------**
C TrmPgm BegSr
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
**
C CallP DltUsrSpc( UsrSpcQ
C : ApiError
C )
**
C Eval *InLr = *On
C Return
**
C EndSr
**-- Print file definition: --------------------------------------------**
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 75 'Scan file fields rep-
O ort'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 4 'File'
O 19 'Library'
O 34 'Scan value'
O 71 'RRN'
O 84 'Field name'
O 90 'Pos.'
O 103 'Field value'
**
OQSYSPRT EF Detail 1
O FlFilNamU 10
O FlFilLibU 22
O PxScnArg 56
O IoRcdRrn 3 71
O F1FldNam 84
O ScnPos 3 89
O FldVal40 132
**
OQSYSPRT EF NoRcds 1
O 26 '(No matches found)'
**-- List fields: ------------------------------------------------------**
P LstFld B
D Pi *
D PxUsrSpc 20a Const
D PxFilNam 10a Const
D PxLibNam 10a Const
**-- 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 )
**-- Retrieve pointer to user space:
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**
D pUsrSpc s *
**-- List file fields: -------------------------------------------------**
**
C CallP LstFldSpc( PxUsrSpc
C : 'FLDL0100'
C : PxFilNam + PxLibNam
C : '*FIRST'
C : '0'
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP RtvPtrSpc( PxUsrSpc
C : pUsrSpc
C )
**
C Return pUsrSpc
C Else
**
C Return *Null
C EndIf
**
P LstFld E
**-- To upper case: ----------------------------------------------------**
P ToUpper B
D Pi 1024a Varying
D InpStr 1024a Const Varying
**
D OutStr s 1024a
**-- Convert to upper case: --------------------------------------------**
**
C Eval RcCaseRqs = Upper
**
C CallP CvtCase( CcRqsCtlBlk
C : InpStr
C : OutStr
C : %Len( InpStr )
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return InpStr
**
C Else
C Return %TrimR( OutStr )
C EndIf
**
P ToUpper E
**-- To lower case: ----------------------------------------------------**
P ToLower B
D Pi 1024a Varying
D InpStr 1024a Const Varying
**
D OutStr s 1024a
**-- Convert to lower case: --------------------------------------------**
**
C Eval RcCaseRqs = Lower
**
C CallP CvtCase( CcRqsCtlBlk
C : InpStr
C : OutStr
C : %Len( InpStr )
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return InpStr
**
C Else
C Return %TrimR( OutStr )
C EndIf
**
P ToLower E
And the calling program:
**
** Description : Find database field containing scan string
**
** Compile options:
**
** CrtRpgMod Module( CBX103T ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX103T )
** Module( CBX103T )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Program parameters: -----------------------------------------------**
** File name:
D PxFilNam s 10a Inz( 'filename' )
** Library name, *LIBL or *CURLIB:
D PxLibNam s 10a Inz( 'lib name' )
** Scan argument:
D PxScnArg s 32a Inz( 'scan string' )
** Scan case sensitive, Y=Yes:
D PxCasSns s 1a Inz( 'Y' )
**
C Call 'CBX103'
C Parm PxFilNam
C Parm PxLibNam
C Parm PxScnArg
C Parm PxCasSns
**
C Eval *InLr = *On
C Return
**
Thanks to Carsten Flensburg
阅读(916) | 评论(0) | 转发(0) |
