You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG105R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG105R4: Select field
* Copyright (C) 2000 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:
**********************************************************************************************
* Field selection screen
FDBG105DF CF E WORKSTN INFDS(SCREEN#DS)
F SFILE(SFL:RRN)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* Program Name
D SDS
D SDS#PGM 10
*
D Screen#DS DS
D KeyPress 1 OVERLAY(Screen#DS:369)
* ==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_VaryField 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
D L_FormatName 10A OVERLAY( RcdL0100 : 1 )
*
D DS
D Ovrdb1 60 INZ('OVRDBF FILE(DBGDFTD1-
D ) TOFILE(DBGDFTD1) S-
D ECURE(*YES) ')
*
D DS
D Ovrdb2 60 INZ('OVRDBF FILE(DBGDFTH1-
D ) TOFILE(DBGDFTH1) S-
D ECURE(*YES) ')
*
D DS
D Ovrdb3 60 INZ('OVRDBF FILE(DBGDFTK1-
D ) TOFILE(DBGDFTK1) S-
D ECURE(*YES) ')
*
D DS
D Dltovr 60 INZ('DLTOVR FILE(DBGDFTD1-
D DBGDFTH1 DBGDFTK1) -
D LVL(*) ')
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D Cmdlength S 15 5
D Cmdstring S 256
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 InitialSiz S 9B 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D ListFormat S 8
D Number4 S 4 0
D Number1 S 1 0
D OverrideProc S 1 INZ('0')
D P#Field S 10
D P#Library S 10
D P#Pgm S 10
D PublicAut S 10 INZ('*ALL ')
D QualifyFile S 20
D ReturnCode S 7
D ReplaceSpc S 10 INZ('*YES ')
D Rrn S 4 0
D StartPos S 9B 0 INZ(1)
D TextDescrp S 50 INZ('QUSLRCD/QUSLFLD List APIs')
D UserSpace S 20 INZ('DBG105US QTEMP ')
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
D F3 C CONST(X'33')
D F12 C CONST(X'3C')
D HELP C CONST(X'F3')
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P#FILE
C PARM P#Library
C PARM P#TEXT
C PARM P#Field
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
* Initialisation
C EXSR Inits
* Repeat display until exit requested
B001 C DOW KeyPress <> F3
*
C EVAL *IN36 = Rrn > 0
C WRITE FOOTER
C WRITE MSFLC MSG SUBFILE
C EXFMT SFLCTL DISPLAY SCREEN
* Remove messages from queue after display
C CALL 'DBG045CL' 90
* Process response
B002 C SELECT
* F1/Help pressed
S002 C WHEN KeyPress = HELP
C EXSR HELPTEXT
* F3=Exit
S002 C WHEN KeyPress = F3
C LEAVE
* F12=Previous
S002 C WHEN KeyPress = F12
C LEAVE
* Field selected
S002 C OTHER
B003 C IF Rrn > 0
C READC SFL 80
B004 C IF *IN80 = *off
C EVAL P#Field = S#IFLD
C LEAVE
E004 C ENDIF
E003 C ENDIF
E002 C ENDSL
*
E001 C ENDDO
* EXIT PROGRAM
C EVAL *INLR = *on
C RETURN
**********************************************************************************************
* BUILD: Build subfile for input file
**********************************************************************************************
C BUILD BEGSR
* Clear subfile prior to build
C EVAL Rrn = 0
C EVAL *IN36 = *off
C EVAL *IN35 = *on
C EVAL SFPAGE = 1
C WRITE SFLCTL
* Set up subfile field from file text
* 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
* Load the subfile record from the retrieved entry (in FldL0100DS)
C EVAL Rrn = Rrn + 1
C EVAL S#IFLD = L_FieldName
C EVAL S#ITXT = L_FieldText
C EVAL S#IITP = L_DataType
* If numeric, set size & decimal places
B003 C IF L_Digits > 0
C EVAL Number4 = L_Digits
C EVAL S#INLN = %EDITC(Number4 : 'Z')
C EVAL Number1 = L_DecimalPos
C MOVE Number1 S#INSC
* Otherwise just set the size
X003 C ELSE
C EVAL Number4 = L_Length
C EVAL S#INLN = %EDITC(Number4 : 'Z')
C EVAL S#INSC = *blanks
E003 C ENDIF
* Dump the record to screen
C WRITE SFL
* 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
*
C ENDSR
**********************************************************************************************
* HelpText: Prompt the helptext for this screen
**********************************************************************************************
C HELPTEXT BEGSR
* In case this is called in the same stack as an existing edit session (editing scripts?)
* make sure the files don't clash. Force secure override to the helptext document set.
C CALL 'QCMDEXC' 90
C PARM Ovrdb1 Cmdstring
C PARM 60 Cmdlength
*
C CALL 'QCMDEXC' 90
C PARM Ovrdb2 Cmdstring
C PARM 60 Cmdlength
*
C CALL 'QCMDEXC' 90
C PARM Ovrdb3 Cmdstring
C PARM 60 Cmdlength
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
* Remove overrides before continuing
C CALL 'QCMDEXC' 90
C PARM Dltovr Cmdstring
C PARM 60 Cmdlength
*
C ENDSR
**********************************************************************************************
* Inits: Program initialisation
**********************************************************************************************
C Inits BEGSR
* Get company name
C *DTAARA DEFINE DBGCOMP COMPNY
C IN COMPNY
* 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
* Build subfile for display
C EXSR BUILD
*
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:24: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