Function VSAM130: Tiered System Variable Evaluation
Name: VSAM130
Description: The following RDML function demonstrates the evaluation of a number of system variables that are used to implement and control a tiered application management scheme.
Special Note: You should check this function into your iSeries server system and compile it there as well as in your Visual LANSA environment.
FUNCTION OPTIONS(*HEAVYUSAGE *DIRECT *MLOPTIMIZE *ALP_SYSTEM_VARIABLE);
********** COMMENT(This RDML function evaluates the system variables);
********** COMMENT( *APPL_TIER);
********** COMMENT( *DATA_TIER);
********** COMMENT( *BATCH_TIER);
********** COMMENT( *PRINT_TIER);
********** COMMENT( *END_APPL_TIER);
********** COMMENT( *END_DATA_TIER);
********** COMMENT( *END_BATCH_TIER);
********** COMMENT( *END_PRINT_TIER);
********** COMMENT( *END_ALL_TIERS);
********** COMMENT(-------------------------------------------------------);
EXECUTE SUBROUTINE(LOGIC);
RETURN;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Actual Evaluation Logic);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(LOGIC);
********** COMMENT(Tier details. Refer to the SetTiers for details);
DEFINE FIELD(#TIER_TYPE) TYPE(*CHAR) LENGTH(10) DESC('Tier Type (APPL, PRINT, etc)');
DEFINE FIELD(#TIER_SSN) TYPE(*CHAR) LENGTH(10) DESC('Tier SSN (Symbolic Server Name)');
DEFINE FIELD(#TIER_NETN) TYPE(*CHAR) LENGTH(20) DESC('Tier Network Name');
DEFINE FIELD(#TIER_USER) TYPE(*CHAR) LENGTH(10) DESC('OS User');
DEFINE FIELD(#TIER_PASW) TYPE(*CHAR) LENGTH(10) DESC('OS Password');
DEFINE FIELD(#TIER_A400) TYPE(*CHAR) LENGTH(1) DESC('A = AS/400, O = Other');
DEFINE FIELD(#TIER_COMM) TYPE(*CHAR) LENGTH(1) DESC('Tier uses Commitment Control');
DEFINE FIELD(#TIER_DBCS) TYPE(*CHAR) LENGTH(1) DESC('Tier is DBCS (if applicable)');
DEFINE FIELD(#TIER_LOCK) TYPE(*CHAR) LENGTH(1) DESC('Divert Locks');
DEFINE FIELD(#TIER_CONN) TYPE(*CHAR) LENGTH(1) DESC('Y= Connected, N = Not Conencted');
DEFINE FIELD(#DBMS_USER) TYPE(*CHAR) LENGTH(10) DESC('DBMS User (if applicable)');
DEFINE FIELD(#DBMS_PASW) TYPE(*CHAR) LENGTH(10) DESC('DBMS Password (if applicable)');
DEFINE FIELD(#DBMS_TYPE) TYPE(*CHAR) LENGTH(20) DESC('DBMS Type (if applicable)');
DEFINE FIELD(#DBMS_NAME) TYPE(*CHAR) LENGTH(10) DESC('DBMS Name (if applicable)');
DEFINE FIELD(#TIER_TOTL) TYPE(*DEC) LENGTH(7) DECIMALS(0) DESC('Total Tiers Available');
DEF_LIST NAME(#TIERS) FIELDS(#TIER_TYPE #TIER_NETN #TIER_CONN #TIER_SSN #TIER_USER #TIER_PASW #TIER_A400 #TIER_COMM #TIER_DBCS #TIER_LOCK #DBMS_USER #DBMS_PASW #DBMS_TYPE #DBMS_NAME) COUNTER(#TIER_TOTL) TYPE(*WORKING) ENTRYS(30);
********** COMMENT(Set up the tier details. See subroutine SetTiers);
EXECUTE SUBROUTINE(LOADTIERS);
********** COMMENT(Now handle evluation of the various variables ....);
CASE OF_FIELD(#SYSVAR$NM);
********** COMMENT(Handle *APPL_TIER requests);
WHEN VALUE_IS('= ''*APPL_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(APPL);
********** COMMENT(Handle *DATA_TIER requests);
WHEN VALUE_IS('= ''*DATA_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(DATA);
********** COMMENT(Handle *PRINT_TIER requests);
WHEN VALUE_IS('= ''*PRINT_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(PRINT);
********** COMMENT(Handle *BATCH_TIER requests);
WHEN VALUE_IS('= ''*BATCH_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(BATCH);
********** COMMENT(Handle the various disconnect options );
WHEN VALUE_IS('= ''*END_APPL_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(APPL);
WHEN VALUE_IS('= ''*END_DATA_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(DATA);
WHEN VALUE_IS('= ''*END_PRINT_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(PRINT);
WHEN VALUE_IS('= ''*END_BATCH_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(BATCH);
WHEN VALUE_IS('= ''*END_ALL_TIERS''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(ALL);
********** COMMENT(Handle an unknown system variable name. );
OTHERWISE;
ABORT MSGTXT('Invalid system variable name encountered');
ENDCASE;
********** COMMENT(Evaluation has finished, so return control to the calle);
********** COMMENT(r.);
RETURN;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Connect and DisConnect data tiers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(SETDATA) PARMS((#SRC_OPTN *RECEIVED));
DEFINE FIELD(#SRC_OPTN) TYPE(*CHAR) LENGTH(15);
SELECTLIST NAMED(#TIERS) WHERE('(#Tier_Conn = Y) *and (#Tier_type = Data)');
IF COND('#SRC_OPTN = CONNECT');
USE BUILTIN(CONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ELSE;
USE BUILTIN(DISCONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ENDIF;
ENDSELECT;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle connection to a specified tier );
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(CONNECT) PARMS((#TO_TIER *RECEIVED));
DEFINE FIELD(#TO_TIER) REFFLD(#TIER_TYPE);
DEFINE FIELD(#BRETCODE) TYPE(*CHAR) LENGTH(2);
DEF_COND NAME(*OKAY) COND('#BRetCode = ok');
DEF_COND NAME(*NOTOKAY) COND('#BRetCode *ne ok');
********** COMMENT(Find the tier details and handle tier not found);
LOC_ENTRY IN_LIST(#TIERS) WHERE('#Tier_Type = #To_Tier');
********** COMMENT(If not found, then no remote tier has been defined);
********** COMMENT(for this tier, so it is therefore locally);
********** COMMENT(accesible to the current tier (ie: this logic is);
********** COMMENT(executing on the specified tier already). In this);
********** COMMENT(case the system variable is returned as YES. );
IF_STATUS IS_NOT(*OKAY);
CHANGE FIELD(#SYSVAR$AV) TO(YES);
RETURN;
ENDIF;
********** COMMENT(Otherwise, the requested tier is remotely);
********** COMMENT(defined so we return the system varaible);
********** COMMENT(value as it's SSN (so that the caller can use);
********** COMMENT(the SSN for CALL_SERVER_FUNCTION, etc) and);
********** COMMENT(we also establish a connection to the tier);
********** COMMENT(if one does not already exist.);
CHANGE FIELD(#SYSVAR$AV) TO(#TIER_SSN);
********** COMMENT(If not already connected, make the connection);
IF COND('#Tier_Conn *ne Y');
DEFINE FIELD(#SAVE_USER) REFFLD(#USER);
CHANGE FIELD(#SAVE_USER) TO(*USER);
USE BUILTIN(SET_SESSION_VALUE) WITH_ARGS(USER #TIER_USER);
IF COND('#TIER_A400 = A');
USE BUILTIN(DEFINE_OS_400_SERVER) WITH_ARGS(#TIER_SSN #TIER_NETN #TIER_COMM #TIER_DBCS #TIER_LOCK) TO_GET(#BRETCODE);
ELSE;
DEFINE FIELD(#FULL_XRUN) TYPE(*CHAR) LENGTH(256);
CHANGE FIELD(#FULL_XRUN) TO(*BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBUS=' #DBMS_USER #TIER_USER);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('PSWD=' #DBMS_PASW #TIER_PASW);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBID=' #DBMS_NAME *BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBII=' #DBMS_NAME *BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBUT=' #DBMS_TYPE *BLANKS);
USE BUILTIN(DEFINE_OTHER_SERVER) WITH_ARGS(#TIER_SSN #TIER_NETN #TIER_LOCK N #FULL_XRUN) TO_GET(#BRETCODE);
ENDIF;
IF COND(*OKAY);
USE BUILTIN(CONNECT_SERVER) WITH_ARGS(#TIER_SSN #TIER_PASW) TO_GET(#BRETCODE);
ENDIF;
USE BUILTIN(SET_SESSION_VALUE) WITH_ARGS(USER #SAVE_USER);
IF COND(*NOTOKAY);
ABORT MSGTXT('Unable to connect to specified tier. See previous error messages.');
ENDIF;
EXECUTE SUBROUTINE(SETCONNECT) WITH_PARMS(#TIER_SSN #TIER_NETN Y);
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle setting of connection state of all tiers that);
********** COMMENT(have the same SSN and network name details because);
********** COMMENT(this means that although they are logically separate);
********** COMMENT(tiers they are a single super-server connection );
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(SETCONNECT) PARMS((#OF_SSN *RECEIVED) (#OF_NETN *RECEIVED) (#TO_CONN *RECEIVED));
DEFINE FIELD(#OF_SSN) REFFLD(#TIER_SSN);
DEFINE FIELD(#OF_NETN) REFFLD(#TIER_NETN);
DEFINE FIELD(#TO_CONN) REFFLD(#TIER_CONN);
SELECTLIST NAMED(#TIERS) WHERE('(#Tier_SSN = #Of_SSN) *and (#Tier_NetN = #Of_NetN)');
IF COND('#TIER_TYPE = DATA');
IF COND('#TO_CONN = Y');
USE BUILTIN(CONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ELSE;
USE BUILTIN(DISCONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ENDIF;
ENDIF;
CHANGE FIELD(#TIER_CONN) TO(#TO_CONN);
UPD_ENTRY IN_LIST(#TIERS);
ENDSELECT;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle construction of X_RUN command overrides);
********** COMMENT(for non-AS/400 servers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(ADDXRUN) PARMS((#WRK_KEY *RECEIVED) (#WRK_STR1 *RECEIVED) (#WRK_STR2 *RECEIVED));
DEFINE FIELD(#WRK_KEY) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#WRK_STR1) TYPE(*CHAR) LENGTH(50);
DEFINE FIELD(#WRK_STR2) TYPE(*CHAR) LENGTH(50);
IF_NULL FIELD(#WRK_STR1 #WRK_STR2);
ELSE;
USE BUILTIN(BCONCAT) WITH_ARGS(#FULL_XRUN #WRK_KEY) TO_GET(#FULL_XRUN);
IF_NULL FIELD(#WRK_STR1);
USE BUILTIN(TCONCAT) WITH_ARGS(#FULL_XRUN #WRK_STR2) TO_GET(#FULL_XRUN);
ELSE;
USE BUILTIN(TCONCAT) WITH_ARGS(#FULL_XRUN #WRK_STR1) TO_GET(#FULL_XRUN);
ENDIF;
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle Disconnection from a specified tier);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(DISCONNECT) PARMS((#FROM_TIER *RECEIVED));
DEFINE FIELD(#FROM_TIER) REFFLD(#TIER_TYPE);
DEFINE FIELD(#XXXX) TYPE(*DEC) LENGTH(7) DECIMALS(0);
BEGIN_LOOP USING(#XXXX) TO(#TIER_TOTL);
GET_ENTRY NUMBER(#XXXX) FROM_LIST(#TIERS);
IF COND('( (#Tier_Type = #From_Tier) *or (#From_Tier = ALL) ) *and (#Tier_Conn = Y) ');
DEFINE FIELD(#SAVE_SSN) REFFLD(#TIER_SSN);
CHANGE FIELD(#SAVE_SSN) TO(#TIER_SSN);
EXECUTE SUBROUTINE(SETCONNECT) WITH_PARMS(#TIER_SSN #TIER_NETN N);
USE BUILTIN(DISCONNECT_SERVER) WITH_ARGS(#SAVE_SSN) TO_GET(#BRETCODE);
ENDIF;
END_LOOP;
CHANGE FIELD(#SYSVAR$AV) TO(YES);
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(This routine handles the definition of the tiers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(LOADTIERS);
DEFINE FIELD(#TIERS_DEF) TYPE(*CHAR) LENGTH(1) DEFAULT(N);
********** COMMENT(If the appropriate tiers have not beeen defined);
IF COND('#TIERS_DEF = N');
********** COMMENT(Standard Conditions);
DEF_COND NAME(*AS400) COND('*CPUTYPE = AS400');
DEF_COND NAME(*NOTAS400) COND('*CPUTYPE *NE AS400');
DEF_COND NAME(*CLIENT) COND('*On_Client_System = Y');
********** COMMENT(List File Name);
DEFINE FIELD(#USET_FILE) REFFLD(#SYSVAR$AV);
********** COMMENT(Layout of data stored in TierData.Dat);
DEFINE FIELD(#USET_NAME) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USET_DESC) REFFLD(#STD_TEXTS) DEFAULT('Tier');
DEFINE FIELD(#USET_TYPE) REFFLD(#STD_CODES) DEFAULT(C);
DEFINE FIELD(#USET_NETN) REFFLD(#STD_TEXTS) DEFAULT(*blanks);
DEFINE FIELD(#USET_USER) REFFLD(#STD_OBJ) DEFAULT(QOTHPRDOWN);
DEFINE FIELD(#USET_PASW) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USET_DBCS) REFFLD(#STD_CODES) DEFAULT(N);
DEFINE FIELD(#USET_COMM) REFFLD(#STD_CODES) DEFAULT(N);
DEFINE FIELD(#USET_LOCK) REFFLD(#STD_CODES) DEFAULT(Y);
DEFINE FIELD(#USED_USER) REFFLD(#STD_OBJ) DEFAULT(DBA);
DEFINE FIELD(#USED_PASW) REFFLD(#STD_OBJ) DEFAULT(SQL);
DEFINE FIELD(#USED_NAME) REFFLD(#STD_TEXTS) DEFAULT(LX_LANSA);
DEFINE FIELD(#USED_TYPE) REFFLD(#STD_TEXTS) DEFAULT(SQLANYWHERE);
DEFINE FIELD(#USE_APPL) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_DATA) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_BATCH) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_PRINT) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
GROUP_BY NAME(#XG_USET) FIELDS(#USET_NAME #USET_DESC #USET_TYPE #USET_NETN #USET_USER #USET_PASW #USET_DBCS #USET_COMM #USET_LOCK #USED_USER #USED_PASW #USED_NAME #USED_TYPE #USE_APPL #USE_DATA #USE_BATCH #USE_PRINT);
DEF_LIST NAME(#USET_LIST) FIELDS(#XG_USET) TYPE(*WORKING) ENTRYS(100);
********** COMMENT(Determine what the name of this tier is);
********** COMMENT(Load the list of tiers .... note that on AS/400s this);
********** COMMENT(is not done and the list is left empty, which is OK);
********** COMMENT(because an AS/400 cannot have associated tiers at);
********** COMMENT(this time );
CLR_LIST NAMED(#USET_LIST);
IF COND(*NOTAS400);
DEFINE FIELD(#PASSWORD) TYPE(*CHAR) LENGTH(14) DEFAULT(TIEREXAMPLE);
********** COMMENT(Load the tiered file name. Note the use of a password);
********** COMMENT(which means that it is stored in encypted form. If you );
********** COMMENT(change the password then you should also change );
********** COMMENT(it in VL_SAM134 as well and then delete);
********** COMMENT(any existing TierData.Dat file because it will have);
********** COMMENT(been saved with a different password and thus);
********** COMMENT(be unusable with the new password);
USE BUILTIN(TCONCAT) WITH_ARGS(*PART_DIR 'TierData.Dat') TO_GET(#USET_FILE);
USE BUILTIN(TCONCAT) WITH_ARGS(#USET_FILE ';PASSWORD(' #PASSWORD ')') TO_GET(#USET_FILE);
USE BUILTIN(TRANSFORM_FILE) WITH_ARGS(#USET_LIST #USET_FILE T) TO_GET(#BRETCODE);
ENDIF;
********** COMMENT(Locate this name);
DEFINE FIELD(#THISENTRY) TYPE(*DEC) LENGTH(7) DECIMALS(0);
DEFINE FIELD(#FIND_TIER) REFFLD(#USE_APPL);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = *Current_System') RET_NUMBER(#THISENTRY);
IF_STATUS IS(*OKAY);
********** COMMENT(Load the APPL tier details);
IF COND('#Use_APPL *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_APPL);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(APPL #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the DATA tier details);
IF COND('#Use_DATA *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_DATA);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(DATA #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the PRINT tier details);
IF COND('#Use_PRINT *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_PRINT);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(PRINT #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the BATCH tier details);
IF COND('#Use_BATCH *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_BATCH);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(BATCH #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
ENDIF;
********** COMMENT(Details loaded, no need to do again );
CHANGE FIELD(#TIERS_DEF) TO(Y);
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(ADDTIER is used to define a tier that is accessible);
********** COMMENT(to the current tier);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(ADDTIER) PARMS(#TIER_TYPE #TIER_SSN #TIER_NETN #TIER_USER #TIER_PASW #TIER_A400 #TIER_COMM #TIER_DBCS #TIER_LOCK #DBMS_USER #DBMS_PASW #DBMS_TYPE #DBMS_NAME);
CHANGE FIELD(#TIER_CONN) TO(N);
USE BUILTIN(UPPERCASE) WITH_ARGS(#TIER_USER) TO_GET(#TIER_USER);
ADD_ENTRY TO_LIST(#TIERS);
ENDROUTINE;
Name: VSAM130
Description: The following RDML function demonstrates the evaluation of a number of system variables that are used to implement and control a tiered application management scheme.
Special Note: You should check this function into your iSeries server system and compile it there as well as in your Visual LANSA environment.
FUNCTION OPTIONS(*HEAVYUSAGE *DIRECT *MLOPTIMIZE *ALP_SYSTEM_VARIABLE);
********** COMMENT(This RDML function evaluates the system variables);
********** COMMENT( *APPL_TIER);
********** COMMENT( *DATA_TIER);
********** COMMENT( *BATCH_TIER);
********** COMMENT( *PRINT_TIER);
********** COMMENT( *END_APPL_TIER);
********** COMMENT( *END_DATA_TIER);
********** COMMENT( *END_BATCH_TIER);
********** COMMENT( *END_PRINT_TIER);
********** COMMENT( *END_ALL_TIERS);
********** COMMENT(-------------------------------------------------------);
EXECUTE SUBROUTINE(LOGIC);
RETURN;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Actual Evaluation Logic);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(LOGIC);
********** COMMENT(Tier details. Refer to the SetTiers for details);
DEFINE FIELD(#TIER_TYPE) TYPE(*CHAR) LENGTH(10) DESC('Tier Type (APPL, PRINT, etc)');
DEFINE FIELD(#TIER_SSN) TYPE(*CHAR) LENGTH(10) DESC('Tier SSN (Symbolic Server Name)');
DEFINE FIELD(#TIER_NETN) TYPE(*CHAR) LENGTH(20) DESC('Tier Network Name');
DEFINE FIELD(#TIER_USER) TYPE(*CHAR) LENGTH(10) DESC('OS User');
DEFINE FIELD(#TIER_PASW) TYPE(*CHAR) LENGTH(10) DESC('OS Password');
DEFINE FIELD(#TIER_A400) TYPE(*CHAR) LENGTH(1) DESC('A = AS/400, O = Other');
DEFINE FIELD(#TIER_COMM) TYPE(*CHAR) LENGTH(1) DESC('Tier uses Commitment Control');
DEFINE FIELD(#TIER_DBCS) TYPE(*CHAR) LENGTH(1) DESC('Tier is DBCS (if applicable)');
DEFINE FIELD(#TIER_LOCK) TYPE(*CHAR) LENGTH(1) DESC('Divert Locks');
DEFINE FIELD(#TIER_CONN) TYPE(*CHAR) LENGTH(1) DESC('Y= Connected, N = Not Conencted');
DEFINE FIELD(#DBMS_USER) TYPE(*CHAR) LENGTH(10) DESC('DBMS User (if applicable)');
DEFINE FIELD(#DBMS_PASW) TYPE(*CHAR) LENGTH(10) DESC('DBMS Password (if applicable)');
DEFINE FIELD(#DBMS_TYPE) TYPE(*CHAR) LENGTH(20) DESC('DBMS Type (if applicable)');
DEFINE FIELD(#DBMS_NAME) TYPE(*CHAR) LENGTH(10) DESC('DBMS Name (if applicable)');
DEFINE FIELD(#TIER_TOTL) TYPE(*DEC) LENGTH(7) DECIMALS(0) DESC('Total Tiers Available');
DEF_LIST NAME(#TIERS) FIELDS(#TIER_TYPE #TIER_NETN #TIER_CONN #TIER_SSN #TIER_USER #TIER_PASW #TIER_A400 #TIER_COMM #TIER_DBCS #TIER_LOCK #DBMS_USER #DBMS_PASW #DBMS_TYPE #DBMS_NAME) COUNTER(#TIER_TOTL) TYPE(*WORKING) ENTRYS(30);
********** COMMENT(Set up the tier details. See subroutine SetTiers);
EXECUTE SUBROUTINE(LOADTIERS);
********** COMMENT(Now handle evluation of the various variables ....);
CASE OF_FIELD(#SYSVAR$NM);
********** COMMENT(Handle *APPL_TIER requests);
WHEN VALUE_IS('= ''*APPL_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(APPL);
********** COMMENT(Handle *DATA_TIER requests);
WHEN VALUE_IS('= ''*DATA_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(DATA);
********** COMMENT(Handle *PRINT_TIER requests);
WHEN VALUE_IS('= ''*PRINT_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(PRINT);
********** COMMENT(Handle *BATCH_TIER requests);
WHEN VALUE_IS('= ''*BATCH_TIER''');
EXECUTE SUBROUTINE(CONNECT) WITH_PARMS(BATCH);
********** COMMENT(Handle the various disconnect options );
WHEN VALUE_IS('= ''*END_APPL_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(APPL);
WHEN VALUE_IS('= ''*END_DATA_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(DATA);
WHEN VALUE_IS('= ''*END_PRINT_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(PRINT);
WHEN VALUE_IS('= ''*END_BATCH_TIER''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(BATCH);
WHEN VALUE_IS('= ''*END_ALL_TIERS''');
EXECUTE SUBROUTINE(DISCONNECT) WITH_PARMS(ALL);
********** COMMENT(Handle an unknown system variable name. );
OTHERWISE;
ABORT MSGTXT('Invalid system variable name encountered');
ENDCASE;
********** COMMENT(Evaluation has finished, so return control to the calle);
********** COMMENT(r.);
RETURN;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Connect and DisConnect data tiers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(SETDATA) PARMS((#SRC_OPTN *RECEIVED));
DEFINE FIELD(#SRC_OPTN) TYPE(*CHAR) LENGTH(15);
SELECTLIST NAMED(#TIERS) WHERE('(#Tier_Conn = Y) *and (#Tier_type = Data)');
IF COND('#SRC_OPTN = CONNECT');
USE BUILTIN(CONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ELSE;
USE BUILTIN(DISCONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ENDIF;
ENDSELECT;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle connection to a specified tier );
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(CONNECT) PARMS((#TO_TIER *RECEIVED));
DEFINE FIELD(#TO_TIER) REFFLD(#TIER_TYPE);
DEFINE FIELD(#BRETCODE) TYPE(*CHAR) LENGTH(2);
DEF_COND NAME(*OKAY) COND('#BRetCode = ok');
DEF_COND NAME(*NOTOKAY) COND('#BRetCode *ne ok');
********** COMMENT(Find the tier details and handle tier not found);
LOC_ENTRY IN_LIST(#TIERS) WHERE('#Tier_Type = #To_Tier');
********** COMMENT(If not found, then no remote tier has been defined);
********** COMMENT(for this tier, so it is therefore locally);
********** COMMENT(accesible to the current tier (ie: this logic is);
********** COMMENT(executing on the specified tier already). In this);
********** COMMENT(case the system variable is returned as YES. );
IF_STATUS IS_NOT(*OKAY);
CHANGE FIELD(#SYSVAR$AV) TO(YES);
RETURN;
ENDIF;
********** COMMENT(Otherwise, the requested tier is remotely);
********** COMMENT(defined so we return the system varaible);
********** COMMENT(value as it's SSN (so that the caller can use);
********** COMMENT(the SSN for CALL_SERVER_FUNCTION, etc) and);
********** COMMENT(we also establish a connection to the tier);
********** COMMENT(if one does not already exist.);
CHANGE FIELD(#SYSVAR$AV) TO(#TIER_SSN);
********** COMMENT(If not already connected, make the connection);
IF COND('#Tier_Conn *ne Y');
DEFINE FIELD(#SAVE_USER) REFFLD(#USER);
CHANGE FIELD(#SAVE_USER) TO(*USER);
USE BUILTIN(SET_SESSION_VALUE) WITH_ARGS(USER #TIER_USER);
IF COND('#TIER_A400 = A');
USE BUILTIN(DEFINE_OS_400_SERVER) WITH_ARGS(#TIER_SSN #TIER_NETN #TIER_COMM #TIER_DBCS #TIER_LOCK) TO_GET(#BRETCODE);
ELSE;
DEFINE FIELD(#FULL_XRUN) TYPE(*CHAR) LENGTH(256);
CHANGE FIELD(#FULL_XRUN) TO(*BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBUS=' #DBMS_USER #TIER_USER);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('PSWD=' #DBMS_PASW #TIER_PASW);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBID=' #DBMS_NAME *BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBII=' #DBMS_NAME *BLANKS);
EXECUTE SUBROUTINE(ADDXRUN) WITH_PARMS('DBUT=' #DBMS_TYPE *BLANKS);
USE BUILTIN(DEFINE_OTHER_SERVER) WITH_ARGS(#TIER_SSN #TIER_NETN #TIER_LOCK N #FULL_XRUN) TO_GET(#BRETCODE);
ENDIF;
IF COND(*OKAY);
USE BUILTIN(CONNECT_SERVER) WITH_ARGS(#TIER_SSN #TIER_PASW) TO_GET(#BRETCODE);
ENDIF;
USE BUILTIN(SET_SESSION_VALUE) WITH_ARGS(USER #SAVE_USER);
IF COND(*NOTOKAY);
ABORT MSGTXT('Unable to connect to specified tier. See previous error messages.');
ENDIF;
EXECUTE SUBROUTINE(SETCONNECT) WITH_PARMS(#TIER_SSN #TIER_NETN Y);
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle setting of connection state of all tiers that);
********** COMMENT(have the same SSN and network name details because);
********** COMMENT(this means that although they are logically separate);
********** COMMENT(tiers they are a single super-server connection );
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(SETCONNECT) PARMS((#OF_SSN *RECEIVED) (#OF_NETN *RECEIVED) (#TO_CONN *RECEIVED));
DEFINE FIELD(#OF_SSN) REFFLD(#TIER_SSN);
DEFINE FIELD(#OF_NETN) REFFLD(#TIER_NETN);
DEFINE FIELD(#TO_CONN) REFFLD(#TIER_CONN);
SELECTLIST NAMED(#TIERS) WHERE('(#Tier_SSN = #Of_SSN) *and (#Tier_NetN = #Of_NetN)');
IF COND('#TIER_TYPE = DATA');
IF COND('#TO_CONN = Y');
USE BUILTIN(CONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ELSE;
USE BUILTIN(DISCONNECT_FILE) WITH_ARGS('*' #TIER_SSN);
ENDIF;
ENDIF;
CHANGE FIELD(#TIER_CONN) TO(#TO_CONN);
UPD_ENTRY IN_LIST(#TIERS);
ENDSELECT;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle construction of X_RUN command overrides);
********** COMMENT(for non-AS/400 servers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(ADDXRUN) PARMS((#WRK_KEY *RECEIVED) (#WRK_STR1 *RECEIVED) (#WRK_STR2 *RECEIVED));
DEFINE FIELD(#WRK_KEY) TYPE(*CHAR) LENGTH(10);
DEFINE FIELD(#WRK_STR1) TYPE(*CHAR) LENGTH(50);
DEFINE FIELD(#WRK_STR2) TYPE(*CHAR) LENGTH(50);
IF_NULL FIELD(#WRK_STR1 #WRK_STR2);
ELSE;
USE BUILTIN(BCONCAT) WITH_ARGS(#FULL_XRUN #WRK_KEY) TO_GET(#FULL_XRUN);
IF_NULL FIELD(#WRK_STR1);
USE BUILTIN(TCONCAT) WITH_ARGS(#FULL_XRUN #WRK_STR2) TO_GET(#FULL_XRUN);
ELSE;
USE BUILTIN(TCONCAT) WITH_ARGS(#FULL_XRUN #WRK_STR1) TO_GET(#FULL_XRUN);
ENDIF;
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(Handle Disconnection from a specified tier);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(DISCONNECT) PARMS((#FROM_TIER *RECEIVED));
DEFINE FIELD(#FROM_TIER) REFFLD(#TIER_TYPE);
DEFINE FIELD(#XXXX) TYPE(*DEC) LENGTH(7) DECIMALS(0);
BEGIN_LOOP USING(#XXXX) TO(#TIER_TOTL);
GET_ENTRY NUMBER(#XXXX) FROM_LIST(#TIERS);
IF COND('( (#Tier_Type = #From_Tier) *or (#From_Tier = ALL) ) *and (#Tier_Conn = Y) ');
DEFINE FIELD(#SAVE_SSN) REFFLD(#TIER_SSN);
CHANGE FIELD(#SAVE_SSN) TO(#TIER_SSN);
EXECUTE SUBROUTINE(SETCONNECT) WITH_PARMS(#TIER_SSN #TIER_NETN N);
USE BUILTIN(DISCONNECT_SERVER) WITH_ARGS(#SAVE_SSN) TO_GET(#BRETCODE);
ENDIF;
END_LOOP;
CHANGE FIELD(#SYSVAR$AV) TO(YES);
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(This routine handles the definition of the tiers);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(LOADTIERS);
DEFINE FIELD(#TIERS_DEF) TYPE(*CHAR) LENGTH(1) DEFAULT(N);
********** COMMENT(If the appropriate tiers have not beeen defined);
IF COND('#TIERS_DEF = N');
********** COMMENT(Standard Conditions);
DEF_COND NAME(*AS400) COND('*CPUTYPE = AS400');
DEF_COND NAME(*NOTAS400) COND('*CPUTYPE *NE AS400');
DEF_COND NAME(*CLIENT) COND('*On_Client_System = Y');
********** COMMENT(List File Name);
DEFINE FIELD(#USET_FILE) REFFLD(#SYSVAR$AV);
********** COMMENT(Layout of data stored in TierData.Dat);
DEFINE FIELD(#USET_NAME) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USET_DESC) REFFLD(#STD_TEXTS) DEFAULT('Tier');
DEFINE FIELD(#USET_TYPE) REFFLD(#STD_CODES) DEFAULT(C);
DEFINE FIELD(#USET_NETN) REFFLD(#STD_TEXTS) DEFAULT(*blanks);
DEFINE FIELD(#USET_USER) REFFLD(#STD_OBJ) DEFAULT(QOTHPRDOWN);
DEFINE FIELD(#USET_PASW) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USET_DBCS) REFFLD(#STD_CODES) DEFAULT(N);
DEFINE FIELD(#USET_COMM) REFFLD(#STD_CODES) DEFAULT(N);
DEFINE FIELD(#USET_LOCK) REFFLD(#STD_CODES) DEFAULT(Y);
DEFINE FIELD(#USED_USER) REFFLD(#STD_OBJ) DEFAULT(DBA);
DEFINE FIELD(#USED_PASW) REFFLD(#STD_OBJ) DEFAULT(SQL);
DEFINE FIELD(#USED_NAME) REFFLD(#STD_TEXTS) DEFAULT(LX_LANSA);
DEFINE FIELD(#USED_TYPE) REFFLD(#STD_TEXTS) DEFAULT(SQLANYWHERE);
DEFINE FIELD(#USE_APPL) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_DATA) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_BATCH) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
DEFINE FIELD(#USE_PRINT) REFFLD(#STD_OBJ) DEFAULT(*Blanks);
GROUP_BY NAME(#XG_USET) FIELDS(#USET_NAME #USET_DESC #USET_TYPE #USET_NETN #USET_USER #USET_PASW #USET_DBCS #USET_COMM #USET_LOCK #USED_USER #USED_PASW #USED_NAME #USED_TYPE #USE_APPL #USE_DATA #USE_BATCH #USE_PRINT);
DEF_LIST NAME(#USET_LIST) FIELDS(#XG_USET) TYPE(*WORKING) ENTRYS(100);
********** COMMENT(Determine what the name of this tier is);
********** COMMENT(Load the list of tiers .... note that on AS/400s this);
********** COMMENT(is not done and the list is left empty, which is OK);
********** COMMENT(because an AS/400 cannot have associated tiers at);
********** COMMENT(this time );
CLR_LIST NAMED(#USET_LIST);
IF COND(*NOTAS400);
DEFINE FIELD(#PASSWORD) TYPE(*CHAR) LENGTH(14) DEFAULT(TIEREXAMPLE);
********** COMMENT(Load the tiered file name. Note the use of a password);
********** COMMENT(which means that it is stored in encypted form. If you );
********** COMMENT(change the password then you should also change );
********** COMMENT(it in VL_SAM134 as well and then delete);
********** COMMENT(any existing TierData.Dat file because it will have);
********** COMMENT(been saved with a different password and thus);
********** COMMENT(be unusable with the new password);
USE BUILTIN(TCONCAT) WITH_ARGS(*PART_DIR 'TierData.Dat') TO_GET(#USET_FILE);
USE BUILTIN(TCONCAT) WITH_ARGS(#USET_FILE ';PASSWORD(' #PASSWORD ')') TO_GET(#USET_FILE);
USE BUILTIN(TRANSFORM_FILE) WITH_ARGS(#USET_LIST #USET_FILE T) TO_GET(#BRETCODE);
ENDIF;
********** COMMENT(Locate this name);
DEFINE FIELD(#THISENTRY) TYPE(*DEC) LENGTH(7) DECIMALS(0);
DEFINE FIELD(#FIND_TIER) REFFLD(#USE_APPL);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = *Current_System') RET_NUMBER(#THISENTRY);
IF_STATUS IS(*OKAY);
********** COMMENT(Load the APPL tier details);
IF COND('#Use_APPL *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_APPL);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(APPL #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the DATA tier details);
IF COND('#Use_DATA *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_DATA);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(DATA #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the PRINT tier details);
IF COND('#Use_PRINT *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_PRINT);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(PRINT #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
********** COMMENT(Load the BATCH tier details);
IF COND('#Use_BATCH *ne *blanks');
CHANGE FIELD(#FIND_TIER) TO(#USE_BATCH);
LOC_ENTRY IN_LIST(#USET_LIST) WHERE('#UseT_Name = #FIND_Tier');
IF_STATUS IS(*OKAY);
EXECUTE SUBROUTINE(ADDTIER) WITH_PARMS(BATCH #USET_NAME #USET_NETN #USET_USER #USET_PASW #USET_TYPE #USET_COMM #USET_DBCS #USET_LOCK #USED_USER #USED_PASW #USED_TYPE #USED_NAME);
ENDIF;
GET_ENTRY NUMBER(#THISENTRY) FROM_LIST(#USET_LIST);
ENDIF;
ENDIF;
********** COMMENT(Details loaded, no need to do again );
CHANGE FIELD(#TIERS_DEF) TO(Y);
ENDIF;
ENDROUTINE;
********** COMMENT(-------------------------------------------------------);
********** COMMENT(ADDTIER is used to define a tier that is accessible);
********** COMMENT(to the current tier);
********** COMMENT(-------------------------------------------------------);
SUBROUTINE NAME(ADDTIER) PARMS(#TIER_TYPE #TIER_SSN #TIER_NETN #TIER_USER #TIER_PASW #TIER_A400 #TIER_COMM #TIER_DBCS #TIER_LOCK #DBMS_USER #DBMS_PASW #DBMS_TYPE #DBMS_NAME);
CHANGE FIELD(#TIER_CONN) TO(N);
USE BUILTIN(UPPERCASE) WITH_ARGS(#TIER_USER) TO_GET(#TIER_USER);
ADD_ENTRY TO_LIST(#TIERS);
ENDROUTINE;