|
midrange.com
This based on the CvtToStmF command published in News/400 but pretty
much rewritten to use my procedures.
The bits I guess you should be interested in are the API prototypes and
the subroutine 'ConvertRcd'
--Gerry
'*=====================================================================
'* Convert to Stream File - Process
'*
'* Author:
'* Gerry Tucker, October 2001
'*=====================================================================
/Copy ToolKitCpy,RpgleHSpec
'*---------------------------------------------------------------------
'* Global definitions
'*---------------------------------------------------------------------
/Copy ToolKitCpy,StdTypH
/Copy ToolKitCpy,StdConH
/Copy ToolKitCpy,ChChrH
/Copy ToolKitCpy,CpCmdH
/Copy ToolKitCpy,FdLstH
/Copy ToolKitCpy,FlFilH
/Copy ToolKitCpy,MbMbrH
/Copy ToolKitCpy,MsMsgH
/Copy ToolKitCpy,NbNbrH
/Copy ToolKitCpy,PsStsH
'*---------------------------------------------------------------------
'* Parameters
'*---------------------------------------------------------------------
D QFilNam Ds
D FilNam Like( StdNam )
D FilLib Like( StdNam )
D ObjNam S Like( StdStr )
D FilMbr S Like( StdNam )
D StrDlm S Like( StdChr )
D FldDlm S Like( StdChr )
D IncHdg S 7
D ErrTxt S Like( StdStr )
'*---------------------------------------------------------------------
'* Variables
'*---------------------------------------------------------------------
D RcdBuf S Like( FilBufTyp )
D RcdNbr S Like( StdBin )
D NumPtr S *
D Ocr S Like( StdInt )
D Tok S Like( StdTok )
D dBufLen S 5p 0
D iHdl S Like( StdInt )
D iOpt S Like( StdInt )
D iRtnCod S Like( StdInt )
D uAut S Like( StdUnsInt )
D iNumBytes S Like( StdInt )
D aPath S Like( StdStr )
D iWrtBytes S Like( StdInt )
D Ds Based( pErrNum )
D iErrNum Like( StdInt )
'*---------------------------------------------------------------------
'* Named constants
'*---------------------------------------------------------------------
D WrtOnly C 2
D CrtFil C 8
D Excl C 16
D Trunc C 64
D PubAut C 7
D ColHdg C '*COLHDG'
D Cr C x'0D'
D FldNam C '*FLDNAM'
D Lf C x'0A'
D None C '*NONE'
D Null C x'00'
D TabChr C x'05'
D TblAscii S Like( StdQNam )
D Inz( 'QASCII *LIBL ' )
'*---------------------------------------------------------------------
'* Field list constants
'*---------------------------------------------------------------------
D FldLst S Like( UsrLstDs )
D FldLstNam C 'CVTTOSTMFU'
D FldLstLib C 'QTEMP'
D FldLstSiz C 5120
D FfAry S Like( FfDtaDs ) Dim( 1000 )
D Idx S Like( StdInt ) Inz
D MaxIdx S Like( Idx )
'*---------------------------------------------------------------------
'* Prototype internal procedures
'*---------------------------------------------------------------------
'* Get error number
D GetErrNum Pr * ExtProc( '__errno' )
'* Ebcdic to Ascii conversion
D Xlate Pr ExtPgm( 'QDCXLATE' )
D BufLen 5p 0
D Buf 32767 Options( *VarSize )
D TrnTbl Like( StdQNam )
'* Open a stream file
D Open Pr ExtProc( 'open' )
D Like( StdInt )
D FilPth 32767 Options( *VarSize ) Const
D Opt Like( StdInt ) Value
D FilAut Like( StdUnsInt )
D Options( *NoPass: *Omit )
D CodPag Like( StdInt )
D Options( *NoPass: *Omit )
'* Write to a stream file
D Write Pr ExtProc( 'write' )
D Like( StdInt )
D Hdl Like( StdInt ) Value
D Buf 32767 Options( *VarSize )
D NumBytes Like( StdInt ) Value
'* Close a stream file
D Close Pr ExtProc( 'close' )
D Like( StdInt )
D Hdl Like( StdInt ) Value
D pOutput S * Inz( %Addr( OutputDs ) )
D OutputDs Ds
D Output Like( StdChr ) Dim( 32766 )
* Text buffer
D TextDs Ds
D Text Like( StdChr ) Dim( 32766 )
'*---------------------------------------------------------------------
'* Mainline
'*---------------------------------------------------------------------
C *Entry PList
C Parm QFilNam
C Parm ObjNam
C Parm FilMbr
C Parm StrDlm
C Parm FldDlm
C Parm IncHdg
C ExSr CheckPrms
C ExSr OpenInFil
C ExSr BuildFldLst
C ExSr OpenOutFil
C ExSr CreateHdr
C ExSr ConvertStmf
C ExSr CloseOutFil
C ExSr CloseInFil
C CallP CpExcCmd( 'ChgAut Obj(' + SQuote
+
C %Trim( ObjNam ) + SQuote+')
'+
C 'User( *Public ) '
+
C 'DtaAut( *Rwx ) '
+
C 'ObjAut( *All )' )
C CallP CpExcCmd( 'ChgAut Obj(' + SQuote
+
C %Trim( ObjNam ) + SQuote+')
'+
C 'User(' + %Trim( PsUsr )+')
'+
C 'DtaAut( *Rwx ) '
+
C 'ObjAut( *All )' )
C Eval *InLR = *On
'*---------------------------------------------------------------------
C CheckPrms BegSr
'*---------------------------------------------------------------------
C If Not FlFilFnd( FilNam: FilLib )
C Eval ErrTxt = 'File '
+
C %Trim( FilNam )
+
C ' not found in '
+
C %Trim( FilLib )
C ExSr ExitOnErr
C EndIf
C If Not MbRtvMbr( FilLib: FilNam: FilMbr:
C MdFmt200: MdDtaDs )
C Eval ErrTxt = 'Member '
+
C %Trim( FilMbr )
+
C ' not found in file '
+
C %Trim( FilLib ) + '/'
+
C %Trim( FilNam )
C ExSr ExitOnErr
C Else
C Eval FilLib = MdLib
C Eval FilMbr = MdMbr
C EndIf
C EndSr
*---------------------------------------------------------------------
C BuildFldLst BegSr
*---------------------------------------------------------------------
C CallP UlCrtLst( FldLstNam: FldLstLib:
C FldLstSiz: FldLst )
C CallP FdLstFld( FldLst: FilNam: FilLib:
C '*FIRST' )
C Clear FfAry
C DoW UlNxtLstEnt( FldLst: FfDtaDs )
C Eval Idx = Idx + 1
C Eval FfAry( Idx ) = FfDtaDs
C EndDo
C Eval MaxIdx = Idx
C CallP UlDltLst( FldLst )
C EndSr
*---------------------------------------------------------------------
C CreateHdr BegSr
*---------------------------------------------------------------------
C Select
C When IncHdg = None
C When IncHdg = FldNam
C Clear Output
C For Idx = 1 To MaxIdx
C Eval FfDtaDs = FfAry( Idx )
C If FfAltNam <> *Blanks
C Eval TextDs = FfAltNam
C Else
C Eval TextDs = FfFld
C EndIf
C Eval TextDs = ChStrToUpr( TextDs )
C Eval OutputDs = %Trim( OutputDs )
+
C StrDlm
+
C %Trim( TextDs )
+
C StrDlm + FldDlm
C EndFor
C Eval OutputDs = %SubSt( OutputDs: 1:
C %Len( %Trim( OutputDs )
)
C - 1 )
C ExSr WriteOut
C When IncHdg = ColHdg
C For Ocr = 1 To 3
C Clear Output
C For Idx = 1 To MaxIdx
C Eval FfDtaDs = FfAry( Idx )
C Select
C When Ocr = 1
C Eval TextDs = FfColHdg1
C When Ocr = 2
C Eval TextDs = FfColHdg2
C When Ocr = 3
C Eval TextDs = FfColHdg3
C EndSl
C Eval TextDs = ChStrToUpr( TextDs )
C Eval OutputDs = %Trim( OutputDs )
+
C StrDlm
+
C %Trim( TextDs )
+
C StrDlm + FldDlm
C EndFor
C Eval OutputDs = %SubSt( OutputDs: 1:
C %Len( %Trim( OutputDs )
)
C - 1 )
C ExSr WriteOut
C EndFor
C EndSl
C EndSr
*---------------------------------------------------------------------
C ConvertStmf BegSr
*---------------------------------------------------------------------
C DoW FlGetIn( RcdBuf: RcdNbr )
C ExSr ConvertRcd
C EndDo
C EndSr
*---------------------------------------------------------------------
C ConvertRcd BegSr
*---------------------------------------------------------------------
C Clear Output
C For Idx = 1 To MaxIdx
C Eval FfDtaDs = FfAry( Idx )
C Select
C When FfTyp = 'A' Or
C FfTyp = 'L' Or
C FfTyp = 'T' Or
C FfTyp = 'Z' Or
C FfTyp = 'H'
C Eval TextDs = %SubSt( RcdBuf:
FfOutPos:
C FfLen )
C Eval OutputDs = %Trim( OutputDs )
+
C StrDlm + %Trim( TextDs )
+
C StrDlm + FldDlm
C When FfTyp = 'S'
C ExSr PutNumPtr
C CallP NbNumToTok( NumPtr: FfLen: FfDecPos:
C Tok: LftNumSgn: *On )
C Eval OutputDs = %Trim( OutputDs )
+
C %Trim( Tok )
+
C FldDlm
C When FfTyp = 'P'
C ExSr PutNumPtr
C CallP NbDecToTok( NumPtr: FfDgt: FfDecPos:
C Tok: LftNumSgn: *On )
C Eval OutputDs = %Trim( OutputDs )
+
C %Trim( Tok )
+
C FldDlm
C When FfTyp = 'F'
C ExSr PutNumPtr
C CallP NbFltToTok( NumPtr: Tok )
C Eval OutputDs = %Trim( OutputDs )
+
C %Trim( Tok )
+
C FldDlm
C When FfTyp = 'B' And FfDgt = 9
C ExSr PutNumPtr
C CallP NbIntToTok( NumPtr: Tok: LftNumSgn:
*On )
C Eval OutputDs = %Trim( OutputDs )
+
C %Trim( Tok )
+
C FldDlm
C When FfTyp = 'B'
C ExSr PutNumPtr
C CallP NbSmlIntToTok( NumPtr: Tok:
LftNumSgn:
C *On )
C Eval OutputDs = %Trim( OutputDs )
+
C %Trim( Tok )
+
C FldDlm
C EndSl
C EndFor
C Eval OutputDs = %SubSt( OutputDs: 1:
C %Len( %Trim( OutputDs )
)
C - 1 )
C ExSr WriteOut
C EndSr
*---------------------------------------------------------------------
C WriteOut BegSr
*---------------------------------------------------------------------
C Eval dBufLen = %Len( %Trim( OutputDs )
)
C CallP XLate( dBufLen: OutputDs: TblAscii )
C Eval OutputDs = %Trim( OutputDs ) + Cr +
Lf
C Eval iNumBytes = %Len( %Trim( OutputDs )
)
C Eval iWrtBytes = Write( iHdl: OutputDs:
C iNumBytes )
C Eval pErrNum = GetErrNum
C Select
C When iErrNum = 3025
C Eval ErrTxt = 'Directory does not
exist'
C ExSr ExitOnErr
C When iErrNum = 3506
C Eval ErrTxt = 'Stream file in use'
C ExSr ExitOnErr
C EndSl
C EndSr
*---------------------------------------------------------------------
C PutNumPtr BegSr
*---------------------------------------------------------------------
C Eval NumPtr = %Addr( RcdBuf ) +
FfOutpos
C - 1
C EndSr
*---------------------------------------------------------------------
C OpenInFil BegSr
*---------------------------------------------------------------------
C If Not FlOpnIn( FilNam: FilLib: FilMbr )
C Eval *InLR = *On
C Return
C EndIf
C EndSr
*---------------------------------------------------------------------
C CloseInFil BegSr
*---------------------------------------------------------------------
C CallP FlCloIn
C EndSr
*---------------------------------------------------------------------
C OpenOutFil BegSr
*---------------------------------------------------------------------
C Eval aPath = %Trim( ObjNam ) + Null
C Eval iOpt = WrtOnly + CrtFil + Trunc
C Eval uAut = PubAut
C Eval iHdl = Open( aPath: iOpt: uAut
)
C If iHdl < 0
C Eval pErrNum = GetErrNum
C Select
C When iErrNum = 3471
C Eval ErrTxt = 'Stream file is a
directory'
C ExSr ExitOnErr
C When iErrNum = 3506
C Eval ErrTxt = 'Stream file in use'
C ExSr ExitOnErr
C When iErrNum = 3025
C Eval ErrTxt = 'Directory does not
exist'
C ExSr ExitOnErr
C EndSl
C Eval *InLR = *On
C Return
C EndIf
C EndSr
*---------------------------------------------------------------------
C CloseOutFil BegSr
*---------------------------------------------------------------------
C Eval iRtnCod = Close( iHdl )
C EndSr
*---------------------------------------------------------------------
C Cleanup BegSr
*---------------------------------------------------------------------
C ExSr CloseInFil
C ExSr CloseOutFil
C EndSr
/Copy ToolKitCpy,StdErrPrc
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
