Example: |
The following is a sample API application written in RPG. The sample also uses a DDS file for screen handling and the sample follows the Cobol sample in terms of logic and function.
RPG is an OS/400 language and this example is only supported on OS/400. The RPG and its matching DDS are only distributed on OS/400 releases and can be found in the etc directory of EDHOME as edaapp.rpg and edaapp.dds, respectively.
Note: The gencpgm.sh tool has been enhanced to accept rpg and dds as language types and will dynamically copy IFS files to an appropriate library file for compilation and linking.
FEDAAPP CF E WORKSTN
F SFILE(SFLREC:RRN)
F*
F* This is the RPG ILE source code for the RPG EDAAPP API sample program.
F* There is matching DDS source to go with it for screen handling. This
F* program has been modernized for using a pointer instead of a long for the
F* EID handle, a new name consistent with other api examples, new SCB fields
F* (replacing a filler) plus a few stylistic changes and better comments.
F*
F* Assuming you install to a standard client location (you may need to
F* adjust the directions below for an alternate install location or a
F* newer release level (ie. CLIENT71). If you are using a server release
F* use "srv71" vs. 'client71' in the directions below.
F*
F* Currently gencpgm.sh does not support compile and link of RPG API
F* type programs (the RPG nor the DDS), but should be in place for
F* the 5.3 release. Until then ...
F*
F* To compile and link this program, do the following ...
F*
F* ADDLIBLE CLIENT71
F* CRTDSPF FILE(EDAAPP) SRCFILE(QDDSSRC) RSTDSP(*YES)
F* CRTRPGMOD MODULE(EDAAPP) SRCFILE(QRPGLESRC)
F* CRTPGM PGM(EDAAPP) MODULE(EDAAPP) DETAIL(*NONE) ENTMOD(*FIRST)
F* BNDSRVPGM(EDAAPI)
F*
F* To run the resulting program, do the following ...
F*
F* ADDLIBLE CLIENT71
F* ADDENVVAR ENVVAR(EDAHOME)
F* VALUE('/home/iadmin/ibi/client71/home')
F* ADDENVVAR ENVVAR(EDACS3)
F* VALUE('/home/iadmin/ibi/client71/ffs/etc/odin.cfg')
F* CALL EDAAPP
F*
F* Of course in a realistic application the run-time would be
F* front-ended by some CL that would check lible and add if needed
F* and do CHGENVVAR when needed and set up as a command that might
F* pass parms, but this type of coding is very specific to any given
F* customers needs so is also left to the customer to code.
F*
F*
F* THIS EXAMPLE SHOWS HOW TO "CALL" THE API'S WITH THE
F* NEW CONCEPT OF A PROTOTYPE. BELOW IN THE CODE YOU WILL
F* SEE SEVEN (7) PROTOTYPE EXAMPLES FOR THE SEVEN
F* EXAMPLES INCLUDED IN THIS PROGRAM.
F*
F* NOTE !!! NOTE !!! NOTE !!!
F*
F* AS STATED IN THE SOURCE CODE FOR THE DISPLAY SCREEN
F* FOR THIS PROGRAM - NOT EVERY FEATURE IN THE SCREEN
F* HAS BEEN CODED TO WORK ON THE SCREEN WITH THE PROGRAM.
F* THIS PROGRAM WILL WORK AND OBTAIN DATA FROM THE SERVER
F* BUT THE INITIAL SCREEN CODING FOR USERID AND PASSWORD
F* IS NOT ACTIVE IN THIS PROGRAM.
F*
D LGH S 1 DIM(30)
D EDA S 12 DIM(7) CTDATA PERRCD(1)
D M1 S 22 DIM(1) CTDATA PERRCD(1)
D M2 S 19 DIM(1) CTDATA PERRCD(1)
D M3 S 70 DIM(2) CTDATA PERRCD(1)
D*
D*
D* ECX (and EID within SCB) are void* memory reference handles,
D* do NOT explicitely put anything into them! This use to be handled
D* by a single long in the SCB, but as of 4.x EDA needs separate
D* vars set up as pointers.
D*
D ECX S *
D*
D*SESSION CONTROL BLOCK
D*---------------------
D*
D SCB DS
D EID *
D SID 9B 0
D COMMD 12
D OPSTA 9B 0
D COLCNT 9B 0
D ATUPSZ 9B 0
D BTUPSZ 9B 0
D ROWCNT 9B 0
D MSGTYP 9B 0
D MSGORI 8
D MSGCOD 9B 0
D MSGTXT 136
D MSGLEN 9B 0
D MSGPEN 9B 0
D MSGOVF 9B 0
D USERSCB 8
D PRMCNT 1
D FIL2 1
D XOPEN 6
D*
D*
D*INFO BLOCK--DECSRIBES COLUMN FORMAT
D*-----------------------------------
D*
D INFO DS
D COLUMN 68
D COLEN 9B 0
D COL# 9B 0
D ALIAS 68
D ALLEN 9B 0
D TYPE 9B 0
D ITNLEN 9B 0
D DEC 9B 0
D OPTION 8
D BSIZE 9B 0
D OFSETA 9B 0
D OFSETB 9B 0
D NULL 9B 0
D FIL3 16
D*
D*
D*RESPONSE AREA
D*
D DS
D TUPLE 80
D*TUPLE-SIZE
D DS
D TUPSIZ 9B 0
D*
D*
D*ACTUAL FORMAT
D*-------------
D DS
D ACTFMT 9B 0
D*
D*
D*VARIABLES
D*---------
D*
D VARIAB DS
D LGHID 9B 0
D LGHPAS 9B 0
D LGHSRV 9B 0
D LGHSTM 9B 0
D DPWDLG 9B 0
D*
D*STATEMENT LINES ARRAY
D*---------------------
D*
D*STMP DS
D* STM 200 DIM(200)
D DS
D STM 1 200
D DIM(200)
D*
D SPEEDP DS
D SPEED 9B 0
D*
D WRKPRM DS
D WORKPR 9B 0
D*
D ABORTM DS
D ABMSG 1 45
D MSG1 1 22
D MSCMD 23 34
D MSG2 35 53
D TUPFLG 54 54
D*
D*
D*START POSITION FOR INFO
D*
D DS
D ONE 9B 0
D*
D*
D*SCREEN FIELDS
D*
D SCRFLD DS
D @USER 10
D @PASSW 10
D @SERV 10
D*
D*
D*PROGRAM DS
D*
D SDS
D @USRID 254 263
D*
D EDAINIT PR
D EID *
D OPSTA 9B 0
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE CALL TO THE EDAINIT API.
D* !!!-NOTE-!!! IN A PROTOTYPE WE DESCRIBE THE LENGTH AND TYPE AS
D* ABOVE 9B 0 NOT 4B 0. HERE WE ARE DESCRIBING THE LENGTH IN DIGITS
D* AND # OF DECIMALS, NOT THE NUMBER OF BYTES THE FIELD IS LONG.
D* HOWEVER, WE MUST INDICATE THE TYPE OF DATA, HENCE THE "B".
D* THE ACTUAL BINARY FIELD DESCRIPTIONS OF THE TWO ABOVE PARMS IS
D* IN THE SCB DS CODE. BEFORE YOU SEE THIS TEXT YOU WILL WEE THE
D* ENTRY --SESSION CONTROL BLOCK--.
D*
D EDACONNECT PR
D EID *
D SCB 220A
D XUSER 12A
D LGHID 9B 0
D XPASSW 12A
D LGHPAS 9B 0
D XSERV 12A
D LGHSRV 9B 0
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDACONNECT API.
D*
D* PLEASE NOTE THE FOLLOWING EN RE THE ABOVE THREE FIELD
D* NAMES -XUSER, XPASSW & XSERV. EVEN THOUGH THESE VALUES CAN
D* NEVER BE LONGER THAN TEN (10) CHARACTERS LONG, THEY ARE
D* MADE TO BE TWEVLE (12) LONG DUE TO THE FACT THAT "C"
D* LANGUAGE LIKES EVERYTHING TO LINE UP ON FOUR (4) BYTE
D* BOUNDRIES. FURTHER DOWN IN THE CODE YOU WILL SEE THE MOVEL'S
D* AND FIELD DEFINITION FOR THESE VALUES. THE ABOVE DESIGNATION
D* DOES NOT PROVIDE THE PROGRAM WITH THE PROPER FIELD DESCRIPTION.
D* SO DO NOT ===REPEAT== DO NOT CHANGE THESE TO TEN (10) LONG
D* SINCE THE RESULTS WILL THEN BE UNPREDICTABLE.
D*
D EDAXCONECT PR EXTPROC('EDAXCONNECT')
D SCB 220A
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDAXCONNECT API.
D* THIS PROTOTYPE HAS THE ADDITIONAL KEYWORD ABOVE =="EXTPROC"==
D* YOU WILL NOTICE THE ELEVEN (11)!!! CHARACTER EXTERNAL PROCEDURE
D* NAME--EDAXCONNECT. THIS ALLOWS US TO REFERENCE AN EXTERNAL
D* PROGRAM WITH A NAME LONGER THAN TEN (10) CHARACTERS.
D*
D EDATERM PR
D EID *
D OPSTA 9B 0
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDATERM API.
D*
D EDASQLL PR EXTPROC('EDASQL')
D SCB 220A
D @SQL 200A
D LGHSTM 9B 0
D SPEED 9B 0
D WORKPR 9B 0
D DPSWD 1A
D DPWDLG 9B 0
D ONE 9B 0
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDASQL API.
D* SPECIAL NOTE EN RE THIS PROTOTYPE. YOU WILL SEE THE USE OF
D* THE KEYWORD "EXTPROC" EVEN THOUGH THE PROCEDURE NAME TO BE
D* CALLED IS LESS THAN TEN CHARACTERS. THE PROTOTYPE WAS NAMED
D* EDASQLL (WITH 2 L'S - NO ERROR!!!) POINTING TO THE
D* EXTERNAL PROCEDURE "EDASQL". THIS WAS DONE SINCE THE PROGRAM
D* ALREADY CONTAINED A VALID PROGRAM VARIABLE NAME OF EDASQL SO
D* THE PROTOTYPE NAME IN THE PROGRAM COULD NOT BE "EDASQL".
D* THIS EXPLANATION IS BEING SPECIFICALLY INCLUDED TO HELP TO
D* AVOID CONFUSION ON THE PART OF TECHNICAL STAFF USING THIS NEW
D* METHOD OF CALLING PROGRAMS UNDER THE ILE UMBRELLA.
D* A P. S. TO THE ABOVE. THE PROGRAM DID CONTAIN A VALID VARIABLE
D* DENOTED AS "EDASQL". IN CLEANING UP THE CODE, THAT CODE WENT
D* SOUTH, BUT SINCE THE ABOVE WORKS, ITS' BEING LEFT IN THE PROGRAM.
D*
D EDAINFO PR
D SCB 220A
D ONE 9B 0
D INFO 200A
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDAINFO API.
D*
D EDAFETCH PR
D SCB 220A
D TUPLE 80A
D TUPSIZ 9B 0
D ACTFMT 9B 0
D*
D* ABOVE IS THE PROTOTYPE EXAMPLE FOR THE EDAFETCH API.
D*
C* START TAG
C* ===== ===
C*
C EXSR CLRRTN
C*
C*DISPLAY INITIAL SCREEN
C*----------------------
C*
C EXFMT CPGMR
C*
C *IN03 CABEQ *ON EOJ
C*
C MOVEA '00' *IN(60)
C*EDIT USER
C*---------
C*
C @USER IFGT *BLANKS
C CLEAR LGH
C MOVEA @USER LGH
C EXSR CHKLEN
C* ================
C Z-ADD Z LGHID
C END
C*
C*EDIT PASSWORD
C*-------------
C*
C @PASSW IFGT *BLANKS
C CLEAR LGH
C MOVEA @PASSW LGH
C EXSR CHKLEN
C* ================
C Z-ADD Z LGHPAS
C END
C*
C *IN90 IFEQ *ON
C MOVE *OFF *IN90
C CLEAR LGH
C MOVEA @SERV LGH
C*
C*DETERMINE NUMBER OF CHARACTERS
C*
C EXSR CHKLEN
C* ================
C Z-ADD Z LGHSRV
C ELSE
C Z-ADD 8 LGHSRV
C END
C*
C EXSR INZRTN
C* ================
C*LOOP
C*----
C CONT DOWEQ 'Y'
C EXSR SQLRTN
C ENDDO
C* ================
C*
C*DISCONNECT
C*----------
C EXSR DISCON
C* ================
C*
C*DELETE CONNECTION
C*-----------------
C EXSR DELEDA
C* ================
C*--------------------------------------------------------*
C*EDACONNECT THIS ESTABLISHES A CONNECTION WITH THE *
C*SERVER, WHICH LINKS THE SESSION CONTROL BLOCK TO THE *
C*CURRENT CONTEXT. *
C*--------------------------------------------------------*
C EOJ TAG
C*
C MOVE '1' *INLR
C*
C INZRTN BEGSR
C* ===================
C*
C WRITE CPGMR2
C*
C*EDAINIT - INITIALIZE API/SQL
C*
C CALLP EDAINIT(ECX :OPSTA )
C*
C* ABOVE IS THE FIRST USE IN THE PROGRAM OF THE "CALLP"
C* OPERATION CODE. THIS IS A FREE FORM STATEMENT. THIS IS NEW
C* TO RPG USEAGE. YOU PUT THE PROTOTYPE NAME IN THE FACTOR1
C* LOCATION, THEN FOLLOW IMMEDIATELY WITH A LEFT PARENTHESIS
C* STATE THE FIRST PARM FROM THE PROTOTYPE LIST, THEN USE A
C* COLON AS A DELIMITER (IF MORE THAN ONE PARM) YOU MAY GO ON
C* TO THE NEXT LINE AND CLOSE WITH A RIGHT PARENTHESIS.
C* AS YOU WILL SEE IN THE NEXT PROTOTYPE BELOW, THE PARMS HAVE
C* BEEN PLACED IN GROUPS OF TWO FOR VISUAL OBSERVATION
C* CONVENIENCE.
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(1) MSCMD
C EXSR ABORT
C MOVE 'N' CONT
C MOVE 'Y' AB 1
C GOTO ENDI
C END
C* ===
C*-----------------------------------------------------------*
C*THIS ESTABLISHES A CONNECTION WITH THE SERVER, WHICH LINKS *
C*THE SESSION CONTROL BLOCK TO THE CURRENT CONTEXT (ECX) *
C*-----------------------------------------------------------*
C*
C MOVEL @USER XUSER 12
C MOVEL @PASSW XPASSW 12
C MOVEL @SERV XSERV 12
C*
C CALLP EDACONNECT(ECX :SCB :
C XUSER :LGHID :
C XPASSW :LGHPAS :
C XSERV :LGHSRV)
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*----------------------------------
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(2) MSCMD
C MOVE 'Y' AB 1
C MOVE 'N' CONT
C EXSR ABORT
C END
C*
C ENDI ENDSR
C*
C*LOADS VARIABLES TO BE PASSED AS PARMS
C*-------------------------------------
C*
C*ABORT ROUTINE
C*-------------
C*
C ABORT BEGSR
C* ===== =====
C MOVE OPSTA STATUS 4 0
C MOVE M1(1) MSG1
C MOVE M2(1) MSG2
C MOVEL ABMSG ERR
C MOVE 'N' CONT
C EXFMT CPGMR6
C *IN03 IFEQ *ON
C EXSR DELEDA
C GOTO EOJ
C END
C ENDSR
C* =====
C*INITIALIZE FIELDS
C*-----------------
C*
C CLRRTN BEGSR
C Z-ADD 0 RRN
C MOVE *ON *IN80
C WRITE CTLREC
C MOVE *OFF *IN80
C CLEAR SCB
C Z-ADD 0 SID
C MOVE *BLANKS COMMD
C Z-ADD 0 OPSTA
C Z-ADD 0 COLCNT
C Z-ADD 0 ATUPSZ
C Z-ADD 0 BTUPSZ
C Z-ADD 0 ROWCNT
C Z-ADD 0 MSGTYP
C MOVE *BLANKS MSGORI
C Z-ADD 0 MSGCOD
C MOVE *BLANKS MSGTXT
C Z-ADD 0 MSGLEN
C Z-ADD 0 MSGPEN
C Z-ADD 0 MSGOVF
C MOVE *BLANKS USERSCB
C MOVE *BLANKS PRMCNT
C MOVE *BLANKS FIL2
C MOVE *BLANKS XOPEN
C Z-ADD 0 STATUS
C CLEAR INFO
C CLEAR VARIAB
C CLEAR LGH
C CLEAR STM
C CLEAR VARIAB
C CLEAR TUPLE
C CLEAR TUPSIZ
C Z-ADD 8 LGHSRV
C Z-ADD 0 RRN
C MOVE *ZEROS SPEED
C MOVE 80 TUPSIZ
C Z-ADD 1 ONE
C MOVE 0 DPWDLG
C MOVE 'N' TUPFLG
C MOVE 'N' TFLAG
C MOVE 'Y' CONT
C MOVE ' ' DPSWD 1
C MOVE ' ' CFLAG 1
C MOVE ' ' TUFLG 1
C CLEAR SCRFLD
C MOVEL 'EDASERVE' @SERV
C MOVE 'Y' CONT
C*
C ENDSR
C*
C CHKLEN BEGSR
C* ====== =====
C Z-ADD 1 Z 4 0
C *BLANKS LOOKUP LGH(Z) 95
C *IN95 IFEQ *ON
C SUB 1 Z
C END
C ENDSR
C* =====
C*----------------------------------------------------------------
C*THIS PROGRAM IS DESIGNED TO ACCEPT ANY NUMBER OF SQL STATEMENTS
C*FOR PROCESSING. THE PURPOSE OF THIS FUNCTION IS TO OBTAIN AN SQL
C*QUERY FROM THE USER, AND SEND IT (VIA THE EDASQL FUNCTION) TO
C*SERVER, WHICH THEN CONSTRUCTS THE APPROPRIATE ANSWER SET
C*----------------------------------------------------------------
C SQLRTN BEGSR
C* ====== =====
C CLEAR TUPLE
C CLEAR @SQL
C MOVE *ZEROS LGHSTM
C REDSP TAG
C EXFMT CPGMR5
C MOVE *OFF *IN63
C*
C *IN03 CABEQ *ON EOJ
C*
C @SQL IFEQ *BLANKS
C MOVE *ON *IN63
C GOTO REDSP
C ELSE
C Z-ADD 1 Z
C MOVEA *BLANKS STM
C MOVEA @SQL STM
C @SQL IFEQ 'QUIT'
C EXSR DISCON
C EXSR DELEDA
C GOTO EOJ
C ENDIF
C @SQL IFEQ 'Q'
C EXSR DISCON
C EXSR DELEDA
C GOTO EOJ
C ENDIF
C ';' LOOKUP STM(Z) 88
C *IN88 IFEQ *ON
C SUB 1 Z
C Z-ADD Z LGHSTM
C ADD 1 LGHSTM
C END
C END
C*
C*SEND THE QUERY TO SERVER TO BE EXTRACTED
C*-----------------------------------------
C MOVE *ZEROS WORKPR
C MOVE *ZEROS DPWDLG
C MOVE *ZEROS SPEED
C Z-ADD 1 ONE
C*
C CALLP EDASQLL(SCB :@SQL :
C LGHSTM :SPEED :
C WORKPR :DPSWD :
C DPWDLG :ONE )
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(5) MSCMD
C EXSR ABORT
C MOVE 'N' CONT
C GOTO OUT
C END
C*
C*DISPLAY SEND-MESSAGE
C*--------------------
C WRITE CPGMR3
C* ================
C*CLEAR INFO BLOCK
C*-----------------
C CLEAR INFO
C*
C*------------------------------------------------------------*
C*EDAINFO IS EMPLOYED HERE, NOT TO OBTAIN A DESCRIPTION OF *
C*THE FIRST COLUMN, BUT TO AVOID TRUNCATION DATA. EDAINFO *
C*SETS UP THE TUPLE SIZE AND COLUMN COUNT ENTRIES IN THE SCB. *
C*AS WELL AS RETURNING VALUES TO THE DESIGNATED WORK AREA. *
C*THIS MAKES IT POSSIBLE TO FORECAST WHETHER OR NOT THE *
C*ALLOCATED SPACE FOR THE TUPLE IS SUFFICIENT. *
C*------------------------------------------------------------*
C*
C CALLP EDAINFO(SCB :ONE :
C INFO)
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(6) MSCMD
C EXSR ABORT
C MOVE 'N' CONT
C GOTO OUT
C END
C*
C* ATUPSZ IFGT TUPSIZ
C* MOVE *BLANKS ERR
C* MOVEL MSGTXT ERR
C* EXFMT CPGMR6
C* *IN03 IFEQ *ON
C* EXSR DISCON
C* EXSR DELEDA
C* GOTO EOJ
C* END
C* END
C*
C MOVE 'N' TUPFLG
C*
C* THE ABOVE CODE GROUP HAS BEEN DEACTIVATED BUT LEFT IN
C* THE PROGRAM. THE PURPOSE WAS TO INDICATE AN ERROR IF THE
C* LENGTH OF THE DATA STRING RETURNED HAS EXCEEDED THE
C* LIMIT SET HERE. THE SCREEN SUBFILE FIELD SIZE IS 79A
C* SO IN THE "SUBLOD" S/R WE MOVE LEFT THE RETURNED DATA
C* STRING AND LOSE THE REST.
C*
C*-----------------------------------------------------*
C*CONTROL RETURNS TO THIS POINT WHEN THE ANSWER SET *
C*HAS BEEN PROCESSED. DETERMINE WHETHER THE USER *
C*WOULD LIKE TO ISSUE ANOTHER QUERY *
C*-----------------------------------------------------*
C*
C TUPFLG DOWEQ 'N'
C EXSR PROCS
C ENDDO
C*
C TFLAG CABEQ 'Y' OUT
C*-----------------------------------------------------*
C*
C RRN IFEQ 0
C Z-ADD 1 RRN
C MOVE *BLANKS RESP
C MOVE M3(2) RESP
C WRITE SFLREC
C END
C MOVE *ON *IN53
C*
C WRITE CMDLIN
C EXFMT CTLREC
C*
C *IN03 IFEQ *ON
C MOVE *OFF *IN03
C Z-ADD 0 RRN
C MOVE *ON *IN80
C MOVE *ON *IN79
C MOVE *OFF *IN53
C WRITE CTLREC
C MOVE *OFF *IN80
C MOVE *OFF *IN79
C EXSR DISCON
C EXSR DELEDA
C GOTO EOJ
C END
C*
C*DISPLAY CONTINUE MODE
C*---------------------
C EXFMT CPGMR7
C*
C Z-ADD 0 RRN
C MOVE *ON *IN80
C MOVE *ON *IN79
C WRITE CTLREC
C MOVE *OFF *IN80
C MOVE *OFF *IN79
C*
C OUT ENDSR
C*------------------------------------------------------------*
C PROCS BEGSR
C*-------------------------------------------------------------*
C*THIS FUNCTION IS CALLED TO PROCESS AN ANSWER SET FOLLOWING---*
C*THE COMPLETION OF A EDASQL REQUEST. ITS PURPOSE IS TO EXTRACT*
C*INFORMATION FROM THE ANSWER SET AND DISPLAY IT ON THE SCREEN *
C*-------------------------------------------------------------*
C*
C*CLEAR INFO BLOCK
C*----------------
C Z-ADD 1 ACTFMT
C*
C CALLP EDAFETCH(SCB :TUPLE :
C TUPSIZ :ACTFMT )
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*----------------------------------
C*
C MOVE 'N' TFLAG 1
C OPSTA IFLT *ZEROS
C MOVEL EDA(7) MSCMD
C EXSR ABORT
C MOVE 'N' CONT
C MOVE 'Y' TUPFLG
C MOVE 'Y' TFLAG 1
C GOTO FIN
C END
C*
C*
C*CHECK FOR THE END OF THE SET
C*----------------------------
C*
C OPSTA IFEQ 5
C MOVE 'Y' TUPFLG
C GOTO FIN
C ELSE
C EXSR SUBLOD
C END
C*
C FIN ENDSR
C* === =====
C*
C*---------------------------------------------------------*
C*THIS ROUTINE LOADS THE SUBFILE WITH THE RETURN RESPONSE *
C*FROM THE "C" PROGRAM. *
C*---------------------------------------------------------*
C*
C*
C SUBLOD BEGSR
C ADD 1 RRN 4 0
C MOVEL TUPLE RESP
C WRITE SFLREC
C ENDSR
C*
C*THIS ENDS THE CONNECTION WITH THE SERVER
C*----------------------------------------
C*
C DISCON BEGSR
C*
C CALLP EDAXCONECT(SCB)
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(2) MSCMD
C MOVE OPSTA STATUS 4 0
C MOVE M1(1) MSG1
C MOVE M2(1) MSG2
C MOVEL ABMSG ERR
C MOVE 'N' CONT
C CPG6 TAG
C EXFMT CPGMR6
C *IN03 IFEQ *ON
C EXSR ABORT
C MOVE 'N' CONT
C MOVE '1' *INLR
C GOTO EOJ
C END
C GOTO CPG6
C GOTO FIN2
C END
C*
C*EDATERM-TERMINATE THIS CONTEX
C*-----------------------------
C*
C CALLP EDATERM(ECX :OPSTA )
C*
C*CHECK IF RETURN STATUS IS NEGATIVE
C*
C OPSTA IFLT *ZEROS
C MOVEL EDA(4) MSCMD
C MOVE OPSTA STATUS 4 0
C MOVE M1(1) MSG1
C MOVE M2(1) MSG2
C MOVEL ABMSG ERR
C MOVE 'N' CONT
C EXFMT CPGMR6
C EXSR ABORT
C MOVE 'N' CONT
C END
C*
C FIN2 ENDSR
C*
C*THIS DELETE THE CONNECTION WITH THE SERVER
C*------------------------------------------
C*
C DELEDA BEGSR
C*
C WRITE CPGMR4
C*
C ENDSR
C*
C*ENDS THE JOB
C*
** EDA-COMMAND
EDAINIT
EDACONNECT
EDAXCONNECT
EDATERM
EDASQL
EDAINFO
EDAFETCH
** MESSAGE #1
ERROR OCCURRED DURING
** MESSAGE #2
- RETURN CODE WAS
**
PROGRAM EDAMAIN IN *LIBL NOT FOUND OR CANNOT BE ACCESSED
NO RECORDS TO DISPLAY
A*
A* This is the DDS source code for the RPG ILE EDAAPP API sample program.
A* There is matching RPG source to go with it for screen handling. This
A* is basically the same program as was used for 3.x EDA, but it has
A* slightly modified to read better and reference iWay plus has been
A* goven a name to match the other EDAAPP API sample programs.
A*
A* ==NOTE== Not every feature (such as error handling) included in
A* this example has been programmed to be operational since this is
A* a skeleton. An example of this is error handling in the case of a
A* bad user id and/or password. This primarily left to customers as
A* each may a have preference and be be more familiar with RPG.
A*
A DSPSIZ(*DS3 *DS4)
A PRINT
A CF03(03 'End of Job')
A R CPGMR
A 1 4'Date:'
A 1 10DATE
A EDTCDE(Y)
A DSPATR(HI)
A 2 25'RPG ILE EDAAPP API Sample Program'
A DSPATR(HI RI)
A 1 61'Time:'
A 1 67TIME
A DSPATR(HI)
A 2 4'User:'
A @USRID 10A O 2 10DSPATR(HI)
A 4 10'Enter User Name . . . . . . . . . -
A . .'
A @USER 10A B 4 48
A 60 ERRMSG('Invalid User ID')
A 7 10'Enter Password . . . . . . . . . -
A . .'
A @PASSW 10A B 7 48DSPATR(ND)
A 61 ERRMSG('Invalid Password')
A 10 10'Enter Server Name . . . . . . . . -
A . .'
A @SERV 10A B 10 48CHANGE(90)
A 62 ERRMSG('Server Name Does Not Exist')
A 23 2'Press F3 to Quit'
A 55 MSG 70A O 24 6DSPATR(RI)
A 1 32'iWay Software'
A R CPGMR2
A OVERLAY
A 9 26'Connecting to server...'
A DSPATR(HI)
A R CPGMR3
A CLRL(*ALL)
A OVERLAY
A 9 28'Query sent...'
A DSPATR(HI)
A R CPGMR4
A CLRL(*ALL)
A 10 31'Exiting...'
A DSPATR(HI)
A DSPATR(RI)
A R CPGMR5
A CLRL(*ALL)
A @SQL 200A I 18 46DSPATR(HI)
A DSPATR(PC)
A 63 ERRMSG('Nothing selected, Enter-
A selection and try again!')
A 18 2'Enter SQL query (with trailing-
A semi-colon):'
A DSPATR(HI)
A DSPATR(RI)
A 23 2'Enter (Q)UIT to quit!'
A R CPGMR6
A KEEP
A STATUS 4Y 0O 22 58EDTCDE(Q)
A ERR 55A O 22 2
A 23 20'Press F3 to Exit!'
A R SFLREC SFL
A KEEP
A RESP 79 O 3 2
A R CTLREC SFLCTL(SFLREC)
A KEEP
A ASSUME
A BLINK
A OVERLAY
A N80 SFLDSP
A N80 SFLDSPCTL
A 79 SFLCLR
A 53 SFLEND
A SFLSIZ(0020)
A SFLPAG(0019)
A *DS4 SFLPAG(0019)
A 1 5'Date:'
A 1 59'Time:'
A 1 11DATE
A EDTCDE(Y)
A 1 65TIME
A 1 30'Request Response'
A DSPATR(RI)
A R CMDLIN
A 23 2'Press F3 to Quit, Rollup/Rolldown-
A keys or ENTER (to query again)!'
A DSPATR(RI)
A R CPGMR7
A CLRL(*ALL)
A CONT 1A B 10 45VALUES('Y' 'N')
A 10 20'Enter New Query (Y/N)?'
A DSPATR(RI)
| iWay Software |