You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG100R4 (26 May 2005, MartinRowe)EditAttach
**********************************************************************************************
* DBG100R4: Edit database generation links
* 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)
**********************************************************************************************
* Indicator usage
**********************************************************************************************
* Screen function keys
* 03 (F3) Exit (all screens)
* 05 (F5) Refresh - rebuild SQL statement from sorce & target files
* 06 (F6) Add link - add a new database generation link
* 27 - ROLLUP
* 28 - ROLLDOWN
* Subfile control inds
* Main subfile (SFL1)
* 35 - SFLEND
* 36 - SFLDSP
* N36 - SFLCLR
* Screen error/dspatr inds
* File access inds
* 80 81 82 83
* Error ind (for calls)
* 90
**********************************************************************************************
* FILES:
**********************************************************************************************
* Database Generation links
FDBGDGL00 UF A E K DISK
* Display screen
FDBG100DF CF E WORKSTN
F SFILE(SFL1:RRN)
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* Program name
D SDS
D SDS#PGM 10
D SDS#Parms 37 39 0
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D K#SeqN S LIKE(DGLSEQ)
D K#SrcF S LIKE(DGLSRC)
D K#TgtF S LIKE(DGLTGT)
D Len S 3 0
D P#CmdString S 256
D P#CmdLength S 15 5
D P#DocFile S 20 INZ('DBGSQLD1 *LIBL')
D P#DocMode S 4
D P#Document S 10
D P#ErrorID S 7
D P#Field S 10
D P#File S 10
D P#MsgData S 512
D P#MsgDtaLn S 5 0
D P#MsgFile S 10
D P#MsgfLib S 10
D P#MsgID S 7
D P#MsgType S 10
D P#Pgm S 10
D P#PgmQueue S 10
D P#PgmStack S 5 0
D P#Return S 7
D P#Sequence S LIKE(DGLSEQ)
D P#Source S LIKE(DGLSRC)
D P#Target S LIKE(DGLTGT)
D P#Text S LIKE(DGLTXT)
D Repeat S 1
D Rrn S 4 0
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
D Text1 C CONST('SELECT * FROM ')
D Text2 C CONST(' T1 WHERE EXISTS (SELECT * -
D FROM ')
D Text3 C CONST(' T2 WHERE')
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PLIST
C PARM P#Target
C PARM P#Source
C PARM P#Sequence
C PARM P#Text
C PARM P#Return
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
C LinkKey KLIST
C KFLD DGLTGT
C KFLD DGLSRC
C KFLD DGLSEQ
*
C #LinkKey KLIST
C KFLD K#TgtF
C KFLD K#SrcF
C KFLD K#SeqN
*
C W#LinkKey KLIST
C KFLD W#TGTF
C KFLD W#SRCF
C KFLD W#SEQN
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
C *DTAARA DEFINE DBGCOMP COMPNY
C IN COMPNY
* INITIALIZE
* If parameters passed in, then pgm used in select mode, so position display for input parms
B001 C IF SDS#Parms > 0
C EVAL DGLTGT = P#Target
C EVAL DGLSRC = P#Source
C EVAL DGLSEQ = P#Sequence
E001 C ENDIF
*
C LinkKey SETLL DBGDGL00
* Build first page
C EXSR PAGEUP
* Main Screen display loop
B001 C DOW *IN03 = *off
* Only display subfile if records to show
C EVAL *IN36 = Rrn > 0
* Display command key text
C WRITE FOOTER1
C WRITE MSFLC MSG SUBFILE
C EXFMT SFLCTL1
C CALL 'DBG045CL' 90 REMOVE MSGS
* Process response
B002 C SELECT
* F1/Help pressed
S002 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
* F3=Exit
S002 C WHEN *IN03 = *on
* If parameters passed in, then pgm used in select mode
B003 C IF SDS#Parms > 0
* Set exit parameters & leave the program
C EVAL P#Return = '*CANCEL'
E003 C ENDIF
C GOTO ENDPGM
* F12=Previous
S002 C WHEN *IN12 = *on
* If parameters passed in, then pgm used in select mode
B003 C IF SDS#Parms > 0
* Set exit parameters & leave the program
C EVAL P#Return = '*CANCEL'
E003 C ENDIF
C GOTO ENDPGM
* Positioning request
S002 C WHEN POSSRC <> *blanks
C EXSR POSITION
* Rollup
S002 C WHEN *IN27 = *on
C EXSR PAGEUP
* Rolldown
S002 C WHEN *IN28 = *on
C EXSR PAGEDOWN
* F6=Add link
S002 C WHEN *IN06 = *on
C EXSR ADDLINK
* Otherwise check for subfile record requests
S002 C OTHER
* Only process if subfile records to work with
B003 C IF Rrn > 0
C READC SFL1 81
* Do while more selected records
B004 C DOW *IN81 = *off
B005 C SELECT
* 1=Select
S005 C WHEN #SEL = '1'
* If parameters passed in, then pgm used in select mode
B006 C IF SDS#Parms > 0
* Set exit parameters & leave the program
C EVAL P#Target = S#TGTF
C EVAL P#Source = S#SRCF
C EVAL P#Sequence = S#SEQN
C EVAL P#Text = S#TEXT
C EVAL P#Return = '*SELECT'
C GOTO ENDPGM
E006 C ENDIF
* 2=Change
S005 C WHEN #SEL = '2'
B006 C IF S#SEQN <> 0
C EXSR CHANGELINK
E006 C ENDIF
* 3=Copy
S005 C WHEN #SEL = '3'
B006 C IF S#SEQN <> 0
C EXSR COPYLINK
E006 C ENDIF
* 4=Delete
S005 C WHEN #SEL = '4'
B006 C IF S#SEQN <> 0
C EXSR DELETELINK
E006 C ENDIF
* 5=View
S005 C WHEN #SEL = '5'
C EXSR VIEWLINK
E005 C ENDSL
* Next selected record
C READC SFL1 81
E004 C ENDDO
E003 C ENDIF
*
E002 C ENDSL
* Reload subfile
C EVAL *IN35 = *off SFLEND
C #LinkKey SETLL DBGDGL00
C EXSR PAGEUP
E001 C ENDDO
* Time to go...
C ENDPGM TAG
* ====== ===
C EVAL *INLR = *on
C RETURN
**********************************************************************************************
* PAGEUP: DISPLAY NEXT PAGE
**********************************************************************************************
C PAGEUP BEGSR
* If not at SFLEND
B001 C IF *IN35 = *off
* Reset the relative record number & clear the subfile
C EVAL Rrn = 0
C MOVE ' ' #SEL
C EVAL *IN36 = *off
C WRITE SFLCTL1
* Load a page of entries
B002 C DO 16
C READ (N) DBGDGL00 82
* If record found
B003 C IF *IN82 = *off
C EVAL S#SRCF = DGLSRC
C EVAL S#TGTF = DGLTGT
C EVAL S#TEXT = DGLTXT
C EVAL S#SEQN = DGLSEQ
C EVAL H#SQLR = DGLSQL
* Add this record to the subfile
C EVAL Rrn = Rrn + 1
C WRITE SFL1
* Store first subfile record values for roll down key positioning
B004 C IF Rrn = 1
C EVAL K#SrcF = DGLSRC
C EVAL K#TgtF = DGLTGT
C EVAL K#SeqN = DGLSEQ
E004 C ENDIF
* Otherwise we've hit the end of the file
X003 C ELSE
C EVAL *IN35 = *on SFLEND
E003 C ENDIF
E002 C ENDDO
* If not SFLEND
B002 C IF *IN35 = *off
* Check ahead to see if there will be any more rcds next roll up - if
* not then set SFLEND
C LinkKey SETGT DBGDGL00 35
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* PAGEDOWN: DISPLAY PREVIOUS PAGE
**********************************************************************************************
C PAGEDOWN BEGSR
*
C EVAL *IN35 = *off SFLEND
* Position file to first record on displayed page
C #LinkKey SETLL DBGDGL00
* Set the key values for next roll up if case no previous rcds found
C EVAL DGLSRC = K#SrcF
C EVAL DGLTGT = K#TgtF
C EVAL DGLSEQ = K#SeqN
* Read back to equivalent of top of previous page
B001 C DO 17
C READP (N) DBGDGL00 82
* If less than 'the page + a rcd' rcds exist, reset pointer to last read
B002 C IF *IN82 = *on
C LinkKey SETLL DBGDGL00
C LEAVE
E002 C ENDIF
E001 C ENDDO
* Rebuild the page from current point
C EXSR PAGEUP
*
C ENDSR
**************************************************************************
* POSITION: Reposition subfile to entered value
**************************************************************************
C POSITION BEGSR
*
C EVAL *IN35 = *off SFLEND
C POSSRC SETLL DBGDGL00
C EXSR PAGEUP
* Reset screen fields for next time
C EVAL POSSRC = *blanks
*
C ENDSR
**********************************************************************************************
* ADDLINK: Add database link
**********************************************************************************************
C ADDLINK BEGSR
*
C EVAL W#SRCF = *blanks
C EVAL W#TGTF = *blanks
C EVAL W#SQLR = *blanks
C EVAL W#TEXT = *blanks
C EVAL W#SEQN = 0
*
B001 C DOU Repeat = *off
C WRITE MSFLC MSG SUBFILE
C EXFMT WINDOW1
C CALL 'DBG045CL' 90 REMOVE MSGS
C EVAL Repeat = *off
B002 C SELECT
* F1/Help pressed
S002 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
C EVAL Repeat = *on
* F12=Previous
S002 C WHEN *IN12
C LEAVE
* F5=Refresh
S002 C WHEN *IN05
* Rebuild the SQL statement
C EVAL W#SQLR = Text1 + %TRIM(W#TGTF)
C + Text2 + %TRIM(W#SRCF) + Text3
* Put cursor at end of generated statement
C EXSR SetCursor
C EVAL Repeat = *on
* Target file not defined
S002 C WHEN W#TGTF = *blanks
C EVAL P#MsgID = 'MIT0074'
C EVAL P#MsgData = *blanks
C EVAL P#MsgDtaLn = 0
C EVAL P#PgmStack = 0
C EVAL P#MsgType = '*INFO'
C EVAL Repeat = *on
* F7=Select Target field
S002 C WHEN *IN07
C EXSR GetTgtFld
C EVAL Repeat = *on
* F8=Select Control field
S002 C WHEN *IN08
C EXSR GetCtlFld
C EVAL Repeat = *on
E002 C ENDSL
E001 C ENDDO
*
B001 C IF NOT *IN12
B002 C DOU NOT *IN83
C EVAL W#SEQN = W#SEQN + 1
C W#LinkKey SETLL DBGDGL00 83
E002 C ENDDO
*
B002 C IF NOT *IN83
C EVAL DGLSRC = W#SRCF
C EVAL DGLTGT = W#TGTF
C EVAL DGLSQL = W#SQLR
C EVAL DGLSEQ = W#SEQN
C EVAL DGLTXT = W#TEXT
C WRITE PFDGL
X002 C ELSE
C EVAL P#MsgID = 'MIT0070'
C EVAL P#MsgData = W#SRCF + W#TGTF
C EVAL P#MsgDtaLn = 20
C EVAL P#PgmStack = 0
C EVAL P#MsgType = '*INFO'
*
C EXSR SNDMSG
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* CHANGELINK: Change database link
**********************************************************************************************
C CHANGELINK BEGSR
* Only process links, not scripts
B001 C IF S#TGTF <> *blanks
C EVAL W#SRCF = S#SRCF
C EVAL W#TGTF = S#TGTF
C EVAL W#SQLR = H#SQLR
C EVAL W#TEXT = S#TEXT
C EVAL W#SEQN = S#SEQN
*
B002 C DOU Repeat = *off
C WRITE MSFLC MSG SUBFILE
C EXFMT WINDOW2
C CALL 'DBG045CL' 90 REMOVE MSGS
C EVAL Repeat = *off
B003 C SELECT
* F1/Help pressed
S003 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
C EVAL Repeat = *on
* F12=Previous
S003 C WHEN *IN12
C LEAVE
* F5=Refresh
S003 C WHEN *IN05
* Rebuild the SQL statement
C EVAL W#SQLR = Text1 + %TRIM(W#TGTF)
C + Text2 + %TRIM(W#SRCF) + Text3
* Put cursor at end of generated statement
C EXSR SetCursor
C EVAL Repeat = *on
* F7=Select Target field
S003 C WHEN *IN07
C EXSR GetTgtFld
C EVAL Repeat = *on
* F8=Select Control field
S003 C WHEN *IN08
C EXSR GetCtlFld
C EVAL Repeat = *on
E003 C ENDSL
E002 C ENDDO
*
B002 C IF NOT *IN12
C W#LinkKey CHAIN DBGDGL00 83
B003 C IF NOT *IN83
C EVAL DGLSRC = W#SRCF
C EVAL DGLTGT = W#TGTF
C EVAL DGLSQL = W#SQLR
C EVAL DGLSEQ = W#SEQN
C EVAL DGLTXT = W#TEXT
C UPDATE PFDGL
E003 C ENDIF
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* COPYLINK: Copy database link
**********************************************************************************************
C COPYLINK BEGSR
* Only process links, not scripts
B001 C IF S#TGTF <> *blanks
C EVAL W#SRCF = S#SRCF
C EVAL W#TGTF = S#TGTF
C EVAL W#SQLR = H#SQLR
C EVAL W#TEXT = S#TEXT
C EVAL W#SEQN = 0
*
B002 C DOU Repeat = *off
C WRITE MSFLC MSG SUBFILE
C EXFMT WINDOW1
C CALL 'DBG045CL' 90 REMOVE MSGS
C EVAL Repeat = *off
B003 C SELECT
* F1/Help pressed
S003 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
C EVAL Repeat = *off
* F12=Previous
S003 C WHEN *IN12
C LEAVE
* F5=Refresh
S003 C WHEN *IN05
* Rebuild the SQL statement
C EVAL W#SQLR = Text1 + %TRIM(W#TGTF)
C + Text2 + %TRIM(W#SRCF) + Text3
* Put cursor at end of generated statement
C EXSR SetCursor
C EVAL Repeat = *on
* F7=Select Target field
S003 C WHEN *IN07
C EXSR GetTgtFld
C EVAL Repeat = *on
* F8=Select Control field
S003 C WHEN *IN08
C EXSR GetCtlFld
C EVAL Repeat = *on
E003 C ENDSL
E002 C ENDDO
*
B002 C IF NOT *IN12
B003 C DOU NOT *IN83
C EVAL W#SEQN = W#SEQN + 1
C W#LinkKey SETLL DBGDGL00 83
E003 C ENDDO
B003 C IF NOT *IN83
C EVAL DGLSRC = W#SRCF
C EVAL DGLTGT = W#TGTF
C EVAL DGLSQL = W#SQLR
C EVAL DGLSEQ = W#SEQN
C EVAL DGLTXT = W#TEXT
C WRITE PFDGL
X003 C ELSE
C EVAL P#MsgID = 'MIT0070'
C EVAL P#MsgData = W#SRCF + W#TGTF
C EVAL P#MsgDtaLn = 20
C EVAL P#PgmStack = 0
C EVAL P#MsgType = '*INFO'
*
C EXSR SNDMSG
E003 C ENDIF
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* DELETELINK: Delete database link
**********************************************************************************************
C DELETELINK BEGSR
* Only process links, not scripts
B001 C IF S#TGTF <> *blanks
C EVAL W#SRCF = S#SRCF
C EVAL W#TGTF = S#TGTF
C EVAL W#SQLR = H#SQLR
C EVAL W#TEXT = S#TEXT
C EVAL W#SEQN = S#SEQN
C EVAL W#TITLE = 'Delete Link'
*
B002 C DOU NOT *IN01
C EXFMT WINDOW3
B003 C SELECT
* F1/Help pressed
S003 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
* F12=Previous
S003 C WHEN *IN12
C LEAVE
E003 C ENDSL
E002 C ENDDO
*
B002 C IF NOT *IN12
C W#LinkKey DELETE PFDGL 83
E002 C ENDIF
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* VIEWLINK: View database link
**********************************************************************************************
C VIEWLINK BEGSR
* If this is an actual link (rather than a script entry)
B001 C IF S#SEQN <> 0
C EVAL W#SRCF = S#SRCF
C EVAL W#TGTF = S#TGTF
C EVAL W#SQLR = H#SQLR
C EVAL W#TEXT = S#TEXT
C EVAL W#SEQN = S#SEQN
C EVAL W#TITLE = 'Display Link'
*
B002 C DOU NOT *IN01
C EXFMT WINDOW3
B003 C SELECT
* F1/Help pressed
S003 C WHEN *IN01 = *on
* Call the Helptext Viewer
C CALL 'DBG010R4' 90 Trap errors
C PARM SDS#PGM P#Pgm
* F12=Previous
S003 C WHEN *IN12
C LEAVE
E003 C ENDSL
E002 C ENDDO
* Otherwise display the script document
X001 C ELSE
C CALL 'DBG005CL' 90
C PARM P#DocFile
C PARM S#TGTF P#Document
C PARM '*DSP' P#DocMode
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* SetCursor: Set cursor to end of SQL statement
**********************************************************************************************
C SetCursor BEGSR
*
C EVAL Len = %LEN(%TRIM(W#SQLR))
C Len DIV 50 CSRROW
C MVR CSRCOL
C EVAL CSRCOL = CSRCOL + 2
C ADD 5 CSRROW
*
C ENDSR
**********************************************************************************************
* GetTgtFld: Get Target file field, and add it to SQL statement
**********************************************************************************************
C GetTgtFld BEGSR
*
C CALL 'DBG105CL'
C PARM W#TGTF P#File
C PARM ' ' P#Field
* If field selected, add it at the end of the statement, and put the cursor after it
B001 C IF P#Field <> *blanks
C EVAL W#SQLR = %TRIM(W#SQLR) + ' T1.' + P#Field
C EXSR SetCursor
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* GetCtlFld: Get Control file field, and add it to SQL statement
**********************************************************************************************
C GetCtlFld BEGSR
*
C CALL 'DBG105CL'
C PARM W#SRCF P#File
C PARM ' ' P#Field
* If field selected, add it at the end of the statement, and put the cursor after it
B001 C IF P#Field <> *blanks
C EVAL W#SQLR = %TRIM(W#SQLR) + ' T2.' + P#Field
C EXSR SetCursor
E001 C ENDIF
*
C ENDSR
**********************************************************************************************
* SNDMSG: SEND PROGRAM MESSAGE
**********************************************************************************************
C SNDMSG BEGSR
* Use in-house utility (via system API 'QMHSNDPM')
C CALL 'DBG044R3'
C PARM P#MsgID
C PARM 'DBGMSGF ' P#MsgFile
C PARM '*LIBL ' P#MsgfLib
C PARM P#MsgData
C PARM P#MsgDtaLn
C PARM P#MsgType
C PARM SDS#PGM P#PgmQueue
C PARM P#PgmStack
C PARM ' ' P#ErrorID
*
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:18:21 - 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