Function VSAM145: Tier and Platform Aware Subroutines

LANSA

previous page next page
Function VSAM145: Tier and Platform Aware Subroutines
Name: VSAM145

Description: The following RDML function demonstrates programming techniques that can be used in tier aware and platform aware subroutines.
Special Notes: You should check this function into your iSeries server system and compile it there as well as in your Visual LANSA environment.
FUNCTION OPTIONS(*DIRECT *HEAVYUSAGE *MLOPTIMIZE) RCV_LIST(#OBJ_LIST);
********** COMMENT(This an example of a smart);
********** COMMENT(subroutine that returns a);
********** COMMENT(list of objects of a specified);
********** COMMENT(type that exist in an AS/400);
********** COMMENT(library );
********** COMMENT(===============================);
********** COMMENT(Definitions);
********** COMMENT(===============================);
EXCHANGE FIELDS(#OBJ_RQS #OBJ_TYP #OBJ_LIB #OBJ_MAX) OPTION(*ALWAYS);
DEFINE FIELD(#OBJ_RQS) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#OBJ_TYP) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#OBJ_LIB) TYPE(*CHAR) LENGTH(10);
DEF_LIST NAME(#OBJ_LIST) FIELDS(#OBJ_NAM #OBJ_DES) COUNTER(#OBJ_TOT) TYPE(*WORKING) ENTRYS(500);
********** COMMENT(Layout of data extracted from OS/400);
********** COMMENT(DSPOBJD command);
DEFINE FIELD(#OBJ_RCD) TYPE(*CHAR) LENGTH(256);
DEFINE FIELD(#OBJ_NAM) TYPE(*CHAR) LENGTH(10) TO_OVERLAY(#OBJ_RCD 24);
DEFINE FIELD(#OBJ_DES) TYPE(*CHAR) LENGTH(50) TO_OVERLAY(#OBJ_RCD 59);
********** COMMENT(Output work file details);
DEFINE FIELD(#OUT_FIL) TYPE(*CHAR) LENGTH(10) DEFAULT('obj_list');
DEFINE FIELD(#OUT_LIB) TYPE(*CHAR) LENGTH(10) DEFAULT('qtemp');
********** COMMENT(Other Variable definitions);
DEFINE FIELD(#OBJ_MAX) TYPE(*DEC) LENGTH(7) DECIMALS(0);
DEFINE FIELD(#OBJ_TOT) REFFLD(#OBJ_MAX);
DEFINE FIELD(#OBJ_RET) TYPE(*CHAR) LENGTH(2);
DEF_COND NAME(*OKAY) COND('#OBJ_RET = OK');
DEF_COND NAME(*NOTOKAY) COND('#OBJ_RET *NE OK');
DEF_COND NAME(*NOTAS400) COND('*CPUTYPE *ne AS400');
********** COMMENT(On any tier clear the return list now);
CLR_LIST NAMED(#OBJ_LIST);
********** COMMENT(===============================);
********** COMMENT(If not on application tier then);
********** COMMENT(invoke on the application tier);
********** COMMENT(===============================);
IF COND('*Appl_Tier *ne YES');
USE BUILTIN(CALL_SERVER_FUNCTION) WITH_ARGS(*APPL_TIER *FUNCTION Y Y #OBJ_LIST) TO_GET(#OBJ_RET);
IF COND(*NOTOKAY);
CHANGE FIELD(#OBJ_RQS) TO(END);
ENDIF;
ELSE;
********** COMMENT(===============================);
********** COMMENT(If on application tier then);
********** COMMENT(extract data from DSPOBJD cmd);
********** COMMENT(===============================);
IF COND(*NOTAS400);
MESSAGE MSGTXT('Requested information is not available in this environment');
CHANGE FIELD(#OBJ_RQS) TO(END);
ELSE;
DOUNTIL COND('(#OBJ_RQS = END) *OR (#OBJ_RQS = MORE)');
CASE OF_FIELD(#OBJ_RQS);
WHEN VALUE_IS('= OPEN');
EXECUTE SUBROUTINE(OPEN);
WHEN VALUE_IS('= READ' '= MORE');
EXECUTE SUBROUTINE(READ);
WHEN VALUE_IS('= CLOSE');
EXECUTE SUBROUTINE(CLOSE);
OTHERWISE;
EXECUTE SUBROUTINE(UNKNOWN);
ENDCASE;
ENDUNTIL;
ENDIF;
ENDIF;
RETURN;
********** COMMENT(===============================);
SUBROUTINE NAME(OPEN);
DEFINE FIELD(#OBJ_CMD) TYPE(*CHAR) LENGTH(256);
DEFINE FIELD(#OBJ_LEN) TYPE(*DEC) LENGTH(15) DECIMALS(5) DEFAULT(256);
********** COMMENT(Build OS/400 command and execute);
USE BUILTIN(BCONCAT) WITH_ARGS(DSPOBJD #OBJ_LIB) TO_GET(#OBJ_CMD);
USE BUILTIN(TCONCAT) WITH_ARGS(#OBJ_CMD '/*all objtype(*') TO_GET(#OBJ_CMD);
USE BUILTIN(TCONCAT) WITH_ARGS(#OBJ_CMD #OBJ_TYP ') output(*outfile) outfile(') TO_GET(#OBJ_CMD);
USE BUILTIN(TCONCAT) WITH_ARGS(#OBJ_CMD #OUT_LIB '/' #OUT_FIL ')') TO_GET(#OBJ_CMD);
CALL PGM(QCMDEXC) PARM(#OBJ_CMD #OBJ_LEN) NUM_LEN(*DEFINED);
********** COMMENT(Open result file and setup to read);
USE BUILTIN(ACCESS_FILE) WITH_ARGS(OPEN #OUT_FIL #OUT_LIB) TO_GET(#OBJ_RET);
IF COND(*OKAY);
CHANGE FIELD(#OBJ_RQS) TO(READ);
ELSE;
CHANGE FIELD(#OBJ_RQS) TO(END);
ENDIF;
ENDROUTINE;
********** COMMENT(===============================);
SUBROUTINE NAME(READ);
********** COMMENT(If return list is full, stop now);
********** COMMENT(and indicate that more exist);
IF COND('#OBJ_TOT = #OBJ_MAX');
CHANGE FIELD(#OBJ_RQS) TO(MORE);
********** COMMENT(Else read details and add to list);
ELSE;
USE BUILTIN(ACCESS_FILE) WITH_ARGS(READ #OUT_FIL #OUT_LIB) TO_GET(#OBJ_RET #OBJ_RCD);
IF COND(*okay);
ADD_ENTRY TO_LIST(#OBJ_LIST);
CHANGE FIELD(#OBJ_RQS) TO(READ);
ELSE;
CHANGE FIELD(#OBJ_RQS) TO(CLOSE);
ENDIF;
ENDIF;
ENDROUTINE;
********** COMMENT(===============================);
SUBROUTINE NAME(CLOSE);
USE BUILTIN(ACCESS_FILE) WITH_ARGS(CLOSE #OUT_FIL #OUT_LIB);
CHANGE FIELD(#OBJ_RQS) TO(END);
ENDROUTINE;
********** COMMENT(===============================);
SUBROUTINE NAME(UNKNOWN);
MESSAGE MSGTXT('Unknown request encountered');
CHANGE FIELD(#OBJ_RQS) TO(END);
ENDROUTINE;

previous page start next page