You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG204R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG204R4: Convert Nulls to non-null defaults
* Copyright (C) 2002 Martin Rowe <martin@dbg400.net>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
**********************************************************************************************
H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
**********************************************************************************************
* FILES:
**********************************************************************************************
**********************************************************************************************
* ARRAYS:
**********************************************************************************************
D FldDta S 281 DIM(999)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* Program Name
D SDS
D SDS_PGM 10
* ==List API structures==
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 1 4B 0 INZ(0)
D BytesAvail 5 8B 0 INZ(0)
D Except_ID 9 15
D Reserved 16 16
D Exception 17 272
* Receiver value DS for user space header info (used in first call to QUSRTVUS)
D GenRcvrDS DS
D UserArea 1 64
D GenHdrSize 65 68B 0
D StrucLevel 69 72
D FormatName 73 80
D APIused 81 90
D CreateStamp 91 103
D InfoStatus 104 104
D SizeUSused 105 108B 0
D InpParmOff 109 112B 0
D InpParmSiz 113 116B 0
D HeadOffset 117 120B 0
D HeaderSize 121 124B 0
D ListOffset 125 128B 0
D ListSize 129 132B 0
D ListNumber 133 136B 0
D EntrySize 137 140B 0
* QUSLFLD format FLDL0100 structure
D FldL0100DS DS
D FldL0100
D L_FieldName 10A OVERLAY( FldL0100 : 1 )
D L_DataType 1A OVERLAY( FldL0100 : 11 )
D L_Use 1A OVERLAY( FldL0100 : 12 )
D L_OutBuffer 9B 0 OVERLAY( FldL0100 : 13 )
D L_InBuffer 9B 0 OVERLAY( FldL0100 : 17 )
D L_Length 9B 0 OVERLAY( FldL0100 : 21 )
D L_Digits 9B 0 OVERLAY( FldL0100 : 25 )
D L_DecimalPos 9B 0 OVERLAY( FldL0100 : 29 )
D L_FieldText 50A OVERLAY( FldL0100 : 33 )
D L_EditCode 2A OVERLAY( FldL0100 : 83 )
D L_EditWordLn 9B 0 OVERLAY( FldL0100 : 85 )
D L_EditWord 64A OVERLAY( FldL0100 : 89 )
D L_ColHead1 20A OVERLAY( FldL0100 : 153 )
D L_ColHead2 20A OVERLAY( FldL0100 : 173 )
D L_ColHead3 20A OVERLAY( FldL0100 : 193 )
D L_IntFldName 10A OVERLAY( FldL0100 : 213 )
D L_AltFldName 30A OVERLAY( FldL0100 : 223 )
D L_AltFldLen 9B 0 OVERLAY( FldL0100 : 253 )
D L_NbrDBCS 9B 0 OVERLAY( FldL0100 : 257 )
D L_AllowNull 1A OVERLAY( FldL0100 : 261 )
D L_HostVryInd 1A OVERLAY( FldL0100 : 262 )
D L_DatTimFmt 4A OVERLAY( FldL0100 : 263 )
D L_DatTimSep 1A OVERLAY( FldL0100 : 267 )
D L_VaryLenInd 1A OVERLAY( FldL0100 : 268 )
D L_FldTxtCSID 1A OVERLAY( FldL0100 : 269 )
D L_FldDtaCSID 1A OVERLAY( FldL0100 : 273 )
D L_ColHedCSID 1A OVERLAY( FldL0100 : 277 )
D L_EdtWrdCSID 1A OVERLAY( FldL0100 : 281 )
* QUSLRCD format RCDL0100 structure
D RcdL0100DS DS
D RcdL0100 10
D L_FormatName 10A OVERLAY( RcdL0100 : 1 )
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D Default S 50
D CurrentEnt S 5P 0 INZ(1)
D DataLength S 9B 0 INZ(140)
D ExtendAttr S 10 INZ('USRSPC ')
D FileFormat S 10
D Idx1 S 5 0
D InitialSiz S 9B 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D ListFormat S 8
D LoopTotal S 5 0
D OverrideProc S 1 INZ('0')
D P_CmdString S 500
D P_CmdLength S 15 5
D P_File S 10
D P_Library S 10
D PublicAut S 10 INZ('*ALL ')
D QualifyFile S 20
D ReplaceSpc S 10 INZ('*YES ')
D SQLCmd S 500 VARYING
D StartPos S 9B 0 INZ(1)
D TextDescrp S 50 INZ('QUSLRCD/QUSLFLD List APIs')
D UserSpace S 20 INZ('DBG204US QTEMP ')
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P_File
C PARM P_Library
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
* Initialisation
C EXSR Inits
* Get the field details for this file
C EXSR GetFldDtls
* Determine the null capable fields and update any that actually contain nulls
C EXSR ConvertNull
* Time to go...
C EVAL *INLR = *ON
C RETURN
**********************************************************************************************
* GetFldDtls: Get field details
**********************************************************************************************
C GetFldDtls BEGSR
* Process returned entries
B001 C IF ListNumber > 0
* Set the initial offset for the start of the list entries
C EVAL ListOffset = ListOffset + 1
* Loop through the entries held in the list section of the user space
B002 C DOW CurrentEnt <= ListNumber
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM ListOffset
C PARM EntrySize
C PARM FldL0100DS
C PARM Error_Code
C EVAL Idx1 = Idx1 + 1
C EVAL FldDta(Idx1) = FldL0100
* Bump up the counter & offset for the next entry
C EVAL ListOffset = ListOffset + EntrySize
C EVAL CurrentEnt = CurrentEnt + 1
E002 C ENDDO
E001 C ENDIF
* Set total number of fields in the record
C EVAL LoopTotal = Idx1
*
C ENDSR
**********************************************************************************************
* ConvertNull: Convert any (null capable) fields with null to non-null defaults
**********************************************************************************************
C ConvertNull BEGSR
* Loop through each field entry and process in turn
B001 C DO LoopTotal Idx1
C EVAL FldL0100 = FldDta(Idx1)
* Only if null capable
B002 C IF L_AllowNull = *ON
* Process according to data type
B003 C SELECT
* Character data type
S003 C WHEN L_DataType = 'A'
C EVAL Default = ''''' '''''
* Numeric data type
S003 C WHEN L_DataType = 'S'
C OR L_DataType = 'P'
C OR L_DataType = 'F'
C OR L_DataType = 'B'
C EVAL Default = '0'
* Date data type
S003 C WHEN L_DataType = 'L'
C EVAL Default = '''''0001-01-01'''''
* Time data type
S003 C WHEN L_DataType = 'T'
C EVAL Default = '''''00.00.00'''''
* Timestamp data type
S003 C WHEN L_DataType = 'Z'
C EVAL Default =
C '''''0001-01-01-00.00.00.000000'''''
E003 C ENDSL
*
C EVAL SQLCmd = 'EXCSQL SQL(' + '''update ' +
C %TRIM(P_Library) + '/' + %TRIM(P_File) +
C ' set ' + %TRIM(L_FieldName) + ' = ' +
C %TRIM(Default) + ' where ' +
C %TRIM(L_FieldName) + ' is NULL'')'
C EVAL P_CmdLength = %LEN(SQLCmd)
C CALL (E) 'QCMDEXC'
C PARM SQLCmd P_CmdString
C PARM P_CmdLength
E002 C ENDIF
E001 C ENDDO
*
C ENDSR
**********************************************************************************************
* Inits: Program initialisation
**********************************************************************************************
C Inits BEGSR
* Use the QUSLRCD (List Record Formats) and QUSLFLD (List Fields) APIs to get the fields
* for the input file.
C EVAL QualifyFile = P_File + P_Library
* Create a user space to hold the format list entries
C CALL 'QUSCRTUS'
C PARM UserSpace
C PARM ExtendAttr
C PARM InitialSiz
C PARM InitialVal
C PARM PublicAut
C PARM TextDescrp
C PARM ReplaceSpc
C PARM Error_Code
* List the formats in the file
C CALL 'QUSLRCD'
C PARM UserSpace
C PARM 'RCDL0100' ListFormat
C PARM QualifyFile
C PARM OverrideProc
C PARM Error_Code
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM StartPos
C PARM DataLength
C PARM GenRcvrDS
C PARM Error_Code
* Process returned entries
B001 C IF ListNumber > 0
* Set the initial offset for the start of the list entries
C EVAL ListOffset = ListOffset + 1
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM ListOffset
C PARM EntrySize
C PARM RcdL0100DS
C PARM Error_Code
* Only interested in the first format - there should only be one for a physical file.
C EVAL FileFormat = L_FormatName
E001 C ENDIF
* Now the format name is known, the fields for the file can be retrieved
* Create a user space to hold the field list entries
C CALL 'QUSCRTUS'
C PARM UserSpace
C PARM ExtendAttr
C PARM InitialSiz
C PARM InitialVal
C PARM PublicAut
C PARM TextDescrp
C PARM ReplaceSpc
C PARM Error_Code
* List the fields in the file using the format just obtained
C CALL 'QUSLFLD'
C PARM UserSpace
C PARM 'FLDL0100' ListFormat
C PARM QualifyFile
C PARM FileFormat
C PARM OverrideProc
C PARM Error_Code
* Get the header info for this space
C CALL 'QUSRTVUS'
C PARM UserSpace
C PARM StartPos
C PARM DataLength
C PARM GenRcvrDS
C PARM Error_Code
*
C ENDSR
**********************************************************************************************
Edit | Attach | Print version | History: r1 | Backlinks | View wiki text | Edit wiki text | More topic actions
Topic revision: r1 - 26 May 2005 - 19:57:09 - MartinRowe
Site Map
DBG400
Copyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors. Ideas, requests, problems regarding DBG/400? Send feedback