22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 1 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0001 OPTIONS/EXTEND 0002 FUNCTION DBEVL$WHERE( USRDB$REC, EVAL$STR ) 0003 C 0004 C *************************************************************************** 0005 C 0006 C ** PURPOSE IS TO EVALUATE THE STRING LOCATED WITH GET_FIELD WITH THE 0007 C ** STRING PROVIDED BY A WHERE CLAUSE FOR A POSSIBLE MATCH. 0008 C 0009 C *************************************************************************** 0010 C 0011 C ** DECLARE LOCAL VARIABLE 0012 C 0013 CHARACTER LOC_MATCH*80 0014 C 0015 C ** INCLUDE GLOBAL USERDB DECLARATIONS NEEDED. 0016 C 0017 INCLUDE 'LIFE_DEV:DB_PARAMS.INC/LIST' 0018 1 C 0019 1 C ************************** 0020 1 C 0021 1 C ** DEFINE THE PARAMETERS FOR OPENING THE USER DATABASE DUMP FILE 0022 1 C 0023 1 PARAMETER USRDB$_NUM_FIELDS = 38 ! NUMBER OF DB FIELDS 0024 1 PARAMETER SQL$_MAX_UPDATE = USRDB$_NUM_FIELDS / 2 0025 1 C 0026 1 C ** DEFINE THE PARAMETERS FOR OPENING THE USER DATABASE DUMP FILE 0027 1 C 0028 1 PARAMETER USRDB$_DUMP_NEW = 0 ! CREATE NEW FILE 0029 1 PARAMETER USRDB$_DUMP_OLD = 1 ! READ OLD FILE 0030 1 C 0031 1 C ** DEFINE THE PARAMETERS FOR THE DUMP_UPDATE / GET_DUMP FUNCTION. 0032 1 C 0033 1 PARAMETER USRDB$_DUMP_UPDATE = 10 ! CREATE NEW FILE 0034 1 PARAMETER USRDB$_BUILD_RECORD = 11 ! READ OLD FILE 0035 1 C 0036 1 C ** DEFINE THE PARAMETERS FOR DEFINING SUCCESS/FAILURE OF OPERATION 0037 1 C ** WHEN CALLING A ROUTINE WHICH RETURNS A STATUS CODE. 0038 1 C 0039 1 PARAMETER USRDB$_SUCCESS = 0 0040 1 PARAMETER USRDB$_FAILURE = 1 0041 1 PARAMETER USRDB$_NORECORD = 2 0042 1 C 0043 1 C ************************** 0044 1 C 0045 1 C ** DEFINE THE PARAMETERS FOR MATCHING USERDB DATA TO A SPECIFIC STRING. 0046 1 C 0047 1 PARAMETER USRDB$_MATCH_NA = 0 0048 1 PARAMETER USRDB$_MATCH_EQ = 1 0049 1 PARAMETER USRDB$_MATCH_GT = 2 0050 1 PARAMETER USRDB$_MATCH_LT = 3 0051 1 PARAMETER USRDB$_MATCH_GE = 4 0052 1 PARAMETER USRDB$_MATCH_LE = 5 0053 1 C 0054 1 C ************************** 0055 1 C 0056 1 C ** DEFINE THE PARAMETERS DEFINING THE INDEX KEY NUMBER WITHIN THE USERDB. 0057 1 C ** INDEX KEY NUMBER IS USED FOR EXTRACTING DATA IN A SPECIFIC SORTED ORDER. DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 2 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0058 1 C 0059 1 PARAMETER USRDB$_KEY_USER_IDENT = 0 0060 1 PARAMETER USRDB$_KEY_LAST_NAME = 1 0061 1 PARAMETER USRDB$_KEY_PRIM_WORK = 2 0062 1 PARAMETER USRDB$_KEY_CITY_NAME = 3 0063 1 PARAMETER USRDB$_KEY_STATE = 4 0064 1 PARAMETER USRDB$_KEY_COUNTRY = 5 0065 1 PARAMETER USRDB$_KEY_INSTITUTION = 6 0066 1 PARAMETER USRDB$_KEY_ZIP_CODE = 7 0067 1 PARAMETER USRDB$_KEY_AREA_CODE = 8 0068 1 PARAMETER USRDB$_KEY_NETWORK_ID = 9 0069 1 PARAMETER USRDB$_KEY_PRIM_ACTIVITY= 10 0070 1 PARAMETER USRDB$_KEY_SEC_ACTIVITY = 11 0071 1 PARAMETER USRDB$_KEY_PRIN_EMPLOYER= 12 0072 1 C 0073 1 C ************************** 0074 1 C 0075 1 C ** DEFINE THE PARAMETERS FOR SPECIFYING THE LENGTH OF EACH USERDB FIELD. 0076 1 C 0077 1 PARAMETER USRDB$_FLEN_USER_IDENT = 12 0078 1 PARAMETER USRDB$_FLEN_LAST_NAME = 20 0079 1 PARAMETER USRDB$_FLEN_PRIM_WORK = 4 0080 1 PARAMETER USRDB$_FLEN_CITY_NAME = 40 0081 1 PARAMETER USRDB$_FLEN_STATE = 3 0082 1 PARAMETER USRDB$_FLEN_COUNTRY = 20 0083 1 PARAMETER USRDB$_FLEN_INSTITUTION = 80 0084 1 PARAMETER USRDB$_FLEN_ZIP_CODE = 10 0085 1 PARAMETER USRDB$_FLEN_AREA_CODE = 3 0086 1 PARAMETER USRDB$_FLEN_NETWORK_ID = 2 0087 1 PARAMETER USRDB$_FLEN_FRST_NAME = 20 0088 1 PARAMETER USRDB$_FLEN_MIDDLE_INIT = 1 0089 1 PARAMETER USRDB$_FLEN_NAME_TITLE = 10 0090 1 PARAMETER USRDB$_FLEN_MAIL_STOP = 40 0091 1 PARAMETER USRDB$_FLEN_STREET_ADR_1 = 80 0092 1 PARAMETER USRDB$_FLEN_STREET_ADR_2 = 80 0093 1 PARAMETER USRDB$_FLEN_PHONE_NMBR = 20 0094 1 PARAMETER USRDB$_FLEN_SHORT_INSTITUTE = 10 0095 1 PARAMETER USRDB$_FLEN_NODE_ID = 12 0096 1 PARAMETER USRDB$_FLEN_REMOTE_USER = 20 0097 1 PARAMETER USRDB$_FLEN_DOMAIN_ID = 20 0098 1 PARAMETER USRDB$_FLEN_FAX_INFO = 25 0099 1 PARAMETER USRDB$_FLEN_OTHER_NET = 2 0100 1 PARAMETER USRDB$_FLEN_OTHER_NODE = 12 0101 1 PARAMETER USRDB$_FLEN_OTHER_USER = 20 0102 1 PARAMETER USRDB$_FLEN_OTHER_DOMAIN = 20 0103 1 PARAMETER USRDB$_FLEN_ACCESS_CONTROL = 2 0104 1 PARAMETER USRDB$_FLEN_COMMENTS = 40 0105 1 PARAMETER USRDB$_FLEN_LIFE_USAGE = 1 0106 1 PARAMETER USRDB$_FLEN_NOTIFY = 1 0107 1 PARAMETER USRDB$_FLEN_AUTO_INFO = 4 0108 1 PARAMETER USRDB$_FLEN_SEC_WORK = 12 0109 1 PARAMETER USRDB$_FLEN_PRIM_ACTIVITY = 4 0110 1 PARAMETER USRDB$_FLEN_SEC_ACTIVITY = 4 0111 1 PARAMETER USRDB$_FLEN_PRIN_EMPLOYER = 4 0112 1 PARAMETER USRDB$_FLEN_LOCATION = 20 0113 1 PARAMETER USRDB$_FLEN_DEPARTMENT = 60 0114 1 PARAMETER USRDB$_FLEN_TIME_ZONE = 10 DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 3 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0115 1 C 0116 1 C ************************** 0117 1 C 0118 1 C ** DEFINE THE PARAMETERS FOR LOCATING THE BEGINNING OF A SPECIFIC USERDB FIELD. 0119 1 C 0120 1 PARAMETER USRDB$_FID_USER_IDENT = 0 0121 1 PARAMETER USRDB$_FID_LAST_NAME = USRDB$_FID_USER_IDENT + USRDB$_FLEN_USER_IDENT 0122 1 PARAMETER USRDB$_FID_PRIM_WORK = USRDB$_FID_LAST_NAME + USRDB$_FLEN_LAST_NAME 0123 1 PARAMETER USRDB$_FID_CITY_NAME = USRDB$_FID_PRIM_WORK + USRDB$_FLEN_PRIM_WORK 0124 1 PARAMETER USRDB$_FID_STATE = USRDB$_FID_CITY_NAME + USRDB$_FLEN_CITY_NAME 0125 1 PARAMETER USRDB$_FID_COUNTRY = USRDB$_FID_STATE + USRDB$_FLEN_STATE 0126 1 PARAMETER USRDB$_FID_INSTITUTION = USRDB$_FID_COUNTRY + USRDB$_FLEN_COUNTRY 0127 1 PARAMETER USRDB$_FID_ZIP_CODE = USRDB$_FID_INSTITUTION + USRDB$_FLEN_INSTITUTION 0128 1 PARAMETER USRDB$_FID_AREA_CODE = USRDB$_FID_ZIP_CODE + USRDB$_FLEN_ZIP_CODE 0129 1 PARAMETER USRDB$_FID_NETWORK_ID = USRDB$_FID_AREA_CODE + USRDB$_FLEN_AREA_CODE 0130 1 PARAMETER USRDB$_FID_FRST_NAME = USRDB$_FID_NETWORK_ID + USRDB$_FLEN_NETWORK_ID 0131 1 PARAMETER USRDB$_FID_MIDDLE_INIT = USRDB$_FID_FRST_NAME + USRDB$_FLEN_FRST_NAME 0132 1 PARAMETER USRDB$_FID_NAME_TITLE = USRDB$_FID_MIDDLE_INIT + USRDB$_FLEN_MIDDLE_INIT 0133 1 PARAMETER USRDB$_FID_MAIL_STOP = USRDB$_FID_NAME_TITLE + USRDB$_FLEN_NAME_TITLE 0134 1 PARAMETER USRDB$_FID_STREET_ADR_1 = USRDB$_FID_MAIL_STOP + USRDB$_FLEN_MAIL_STOP 0135 1 PARAMETER USRDB$_FID_STREET_ADR_2 = USRDB$_FID_STREET_ADR_1 + USRDB$_FLEN_STREET_ADR_1 0136 1 PARAMETER USRDB$_FID_PHONE_NMBR = USRDB$_FID_STREET_ADR_2 + USRDB$_FLEN_STREET_ADR_2 0137 1 PARAMETER USRDB$_FID_SHORT_INSTITUTE = USRDB$_FID_PHONE_NMBR + USRDB$_FLEN_PHONE_NMBR 0138 1 PARAMETER USRDB$_FID_NODE_ID = USRDB$_FID_SHORT_INSTITUTE + USRDB$_FLEN_SHORT_INSTITUTE 0139 1 PARAMETER USRDB$_FID_REMOTE_USER = USRDB$_FID_NODE_ID + USRDB$_FLEN_NODE_ID 0140 1 PARAMETER USRDB$_FID_DOMAIN_ID = USRDB$_FID_REMOTE_USER + USRDB$_FLEN_REMOTE_USER 0141 1 PARAMETER USRDB$_FID_FAX_INFO = USRDB$_FID_DOMAIN_ID + USRDB$_FLEN_DOMAIN_ID 0142 1 PARAMETER USRDB$_FID_OTHER_NET = USRDB$_FID_FAX_INFO + USRDB$_FLEN_FAX_INFO 0143 1 PARAMETER USRDB$_FID_OTHER_NODE = USRDB$_FID_OTHER_NET + USRDB$_FLEN_OTHER_NET 0144 1 PARAMETER USRDB$_FID_OTHER_USER = USRDB$_FID_OTHER_NODE + USRDB$_FLEN_OTHER_NODE 0145 1 PARAMETER USRDB$_FID_OTHER_DOMAIN = USRDB$_FID_OTHER_USER + USRDB$_FLEN_OTHER_USER 0146 1 PARAMETER USRDB$_FID_ACCESS_CONTROL = USRDB$_FID_OTHER_DOMAIN + USRDB$_FLEN_OTHER_DOMAIN 0147 1 PARAMETER USRDB$_FID_COMMENTS = USRDB$_FID_ACCESS_CONTROL + USRDB$_FLEN_ACCESS_CONTROL 0148 1 PARAMETER USRDB$_FID_LIFE_USAGE = USRDB$_FID_COMMENTS + USRDB$_FLEN_COMMENTS 0149 1 PARAMETER USRDB$_FID_NOTIFY = USRDB$_FID_LIFE_USAGE + USRDB$_FLEN_LIFE_USAGE 0150 1 PARAMETER USRDB$_FID_AUTO_INFO = USRDB$_FID_NOTIFY + USRDB$_FLEN_NOTIFY 0151 1 PARAMETER USRDB$_FID_SEC_WORK = USRDB$_FID_AUTO_INFO + USRDB$_FLEN_AUTO_INFO 0152 1 PARAMETER USRDB$_FID_PRIM_ACTIVITY = USRDB$_FID_SEC_WORK + USRDB$_FLEN_SEC_WORK 0153 1 PARAMETER USRDB$_FID_SEC_ACTIVITY = USRDB$_FID_PRIM_ACTIVITY + USRDB$_FLEN_PRIM_ACTIVITY 0154 1 PARAMETER USRDB$_FID_PRIN_EMPLOYER = USRDB$_FID_SEC_ACTIVITY + USRDB$_FLEN_SEC_ACTIVITY 0155 1 PARAMETER USRDB$_FID_LOCATION = USRDB$_FID_PRIN_EMPLOYER + USRDB$_FLEN_PRIN_EMPLOYER 0156 1 PARAMETER USRDB$_FID_DEPARTMENT = USRDB$_FID_LOCATION + USRDB$_FLEN_LOCATION 0157 1 PARAMETER USRDB$_FID_TIME_ZONE = USRDB$_FID_DEPARTMENT + USRDB$_FLEN_DEPARTMENT 0158 1 PARAMETER USRDB$_FID_EXTRA_SPACE = USRDB$_FID_TIME_ZONE + USRDB$_FLEN_TIME_ZONE 0159 1 C 0160 1 C ************************** 0161 1 C 0162 INCLUDE 'LIFE_DEV:DB_INTERN.INC/LIST' 0163 1 C 0164 1 C ************************** 0165 1 C 0166 1 C ** DEFINE THE INTERNAL USRDB$ ROUTINE RECORD STRUCTURE. 0167 1 C 0168 1 C 0169 1 STRUCTURE /USRDB$INTERNAL/ 0170 1 UNION 0171 1 MAP DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 4 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0172 1 CHARACTER*12 USER_IDENT 0173 1 CHARACTER*20 LAST_NAME 0174 1 CHARACTER*4 PRIM_WORK 0175 1 CHARACTER*40 CITY_NAME 0176 1 CHARACTER*3 STATE 0177 1 CHARACTER*20 COUNTRY 0178 1 CHARACTER*80 INSTITUTION 0179 1 CHARACTER*10 ZIP_CODE 0180 1 CHARACTER*3 AREA_CODE 0181 1 CHARACTER*2 NETWORK_ID 0182 1 CHARACTER*830 REMAINING_DATA 0183 1 END MAP 0184 1 MAP 0185 1 CHARACTER*1024 INTERNAL_BUFFER 0186 1 END MAP 0187 1 END UNION 0188 1 END STRUCTURE 0189 1 C 0190 1 RECORD /USRDB$INTERNAL/ DBINT 0191 1 C 0192 1 C ************************** 0193 1 C 0194 1 C ** DEFINE THE VARIABLE FOR PASSING THE DB RECORD BETWEEN FUNCTIONS. 0195 1 C 0196 1 CHARACTER USRDB$REC*1024 0197 1 C 0198 1 C ************************** 0199 1 C 0200 INCLUDE 'LIFE_DEV:DB_FUNCS.INC/LIST' 0201 1 C 0202 1 C ************************** 0203 1 C 0204 1 C ** DEFINE THE FUNCTION VARIABLES 0205 1 C 0206 1 INTEGER*4 USRDB$GET_INIT, USRDB$GET_RECORD, 0207 1 & USRDB$PUT_RECORD, USRDB$UPDATE_RECORD, 0208 1 & USRDB$DELETE_RECORD, USRDB$CLEAR_RECORD, 0209 1 & USRDB$GET_FIELD, USRDB$PUT_FIELD, 0210 1 & USRDB$PUT_DUMP, USRDB$GET_DUMP, 0211 1 & USRDB$SQL, USRDB$LOCATE 0212 1 C 0213 1 INTEGER*4 DBEVL$WHERE, DBEVL$LOGICAL, 0214 1 & DBEVL$COMPOSE, DBEVL$SORT, 0215 1 & DBEVL$DEF_SORT, DBEVL$PARSE, 0216 1 & DBEVL$SELECT, DBEVL$UPDATE, 0217 1 & DBCRS$FIELD_IDENT, DBCPY$COPY 0218 1 C 0219 1 C ************************** 0220 1 C 0221 INCLUDE 'LIFE_DEV:DB_WHERE.INC/LIST' 0222 1 C-------------------------------------------------------------- 0223 1 C ** DEFINITION OF RECORD STRUCTURE FOR SQL STYLE WHERE CLAUSE 0224 1 C 0225 1 STRUCTURE /EVAL_WHERE/ 0226 1 UNION 0227 1 MAP 0228 1 CHARACTER*80 FIND, MATCH DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 5 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0229 1 INTEGER*4 FSLEN, LENDF, STPNT 0230 1 INTEGER*4 FID, MPNTR 0231 1 LOGICAL EVAL 0232 1 CHARACTER*1 FUNC, QUAL 0233 1 END MAP 0234 1 MAP 0235 1 CHARACTER*186 BUFFER 0236 1 END MAP 0237 1 END UNION 0238 1 END STRUCTURE 0239 1 C 0240 1 C ** DEFINE UP TO USRDB$_NUM_FIELDS RECORDS FOR PERFORMING WHERE CLAUSE. 0241 1 C 0242 1 RECORD /EVAL_WHERE/ EVAL$REC(USRDB$_NUM_FIELDS), EVAL$STR 0243 1 C 0244 1 C-------------------------------------------------------------- 0245 C 0246 C ** SET RETURN STATUS OF THE FUNCTION. 0247 C 0248 DBEVL$WHERE = USRDB$_FAILURE 0249 C 0250 C ** GET VALUE OF THE FIELD FROM RECORD RETURNED. 0251 C 0252 ISTAT = USRDB$GET_FIELD( USRDB$REC, EVAL$STR.FID, LOC_MATCH, LEN_LOC ) 0253 C 0254 C ** DETERMINE MATCH TYPE TO BE MADE. 0255 C 0256 IF ((EVAL$STR.MPNTR .EQ. 1) .AND. (LEN_LOC .GE. EVAL$STR.LENDF)) THEN 0257 C 0258 C ** EVALUATION FOR * TYPE MATCH. 0259 C 0260 IPNT = LEN_LOC - EVAL$STR.LENDF + 1 0261 IF (IPNT .LE. 0) GOTO 5000 0262 IF (LOC_MATCH(IPNT:LEN_LOC) .EQ. EVAL$STR.MATCH(1:EVAL$STR.LENDF)) DBEVL$WHERE = USRDB$_SUCCESS 0263 C 0264 ELSE IF ((EVAL$STR.MPNTR .EQ. 2) .AND. (LEN_LOC .GE. EVAL$STR.LENDF)) THEN 0265 C 0266 C ** EVALUATION OF * TYPE MATCH 0267 C 0268 IF (INDEX(LOC_MATCH(1:LEN_LOC), EVAL$STR.MATCH(1:EVAL$STR.LENDF)) .NE. 0) DBEVL$WHERE = USRDB$_SUCCESS 0269 C 0270 ELSE IF ((EVAL$STR.MPNTR .EQ. 3) .AND. (LEN_LOC .GE. EVAL$STR.LENDF)) THEN 0271 C 0272 C ** EVALUATION OF %%% TYPE MATCH 0273 C 0274 IF (LOC_MATCH(EVAL$STR.STPNT:EVAL$STR.LENDF) .EQ. EVAL$STR.MATCH(EVAL$STR.STPNT:EVAL$STR.LENDF)) DBEVL$WHERE = USRDB$_SUCCESS 0275 C 0276 ELSE IF ((EVAL$STR.MPNTR .EQ. 4) .AND. (LEN_LOC .GE. EVAL$STR.LENDF)) THEN 0277 C 0278 C ** EVALUATION OF %%%* TYPE MATCH 0279 C 0280 IPNT = LEN_LOC - EVAL$STR.STPNT + 1 0281 IF (IPNT .LE. 0) GOTO 5000 0282 JPNT = IPNT + EVAL$STR.LENDF - 1 0283 IF (LOC_MATCH(IPNT:JPNT) .EQ. EVAL$STR.MATCH(1:EVAL$STR.LENDF)) DBEVL$WHERE = USRDB$_SUCCESS 0284 C 0285 ELSE IF ((EVAL$STR.MPNTR .EQ. 0) .AND. (LEN_LOC .GE. EVAL$STR.LENDF)) THEN DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 6 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0286 C 0287 C ** EVALUATION FOR EXACT MATCH 0288 C 0289 IF (LOC_MATCH(1:LEN_LOC) .EQ. EVAL$STR.MATCH(EVAL$STR.STPNT:EVAL$STR.LENDF)) DBEVL$WHERE = USRDB$_SUCCESS 0290 C 0291 ENDIF 0292 C 0293 C ** RETURN TO CALLING ROUTINE. 0294 C 0295 5000 RETURN 0296 END PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 463 PIC CON REL LCL SHR EXE RD NOWRT QUAD 2 $LOCAL 8264 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 8727 ENTRY POINTS Address Type Name 0-00000000 I*4 DBEVL$WHERE VARIABLES Address Type Name Address Type Name ** I*4 DBCPY$COPY ** I*4 DBCRS$FIELD_IDENT ** I*4 DBEVL$COMPOSE ** I*4 DBEVL$DEF_SORT ** I*4 DBEVL$LOGICAL ** I*4 DBEVL$PARSE ** I*4 DBEVL$SELECT ** I*4 DBEVL$SORT ** I*4 DBEVL$UPDATE ** I*4 IPNT ** I*4 ISTAT ** I*4 JPNT 2-00001FF0 I*4 LEN_LOC 2-00001F9C CHAR LOC_MATCH ** I*4 USRDB$CLEAR_RECORD ** I*4 USRDB$DELETE_RECORD ** I*4 USRDB$GET_DUMP ** I*4 USRDB$GET_INIT ** I*4 USRDB$GET_RECORD ** I*4 USRDB$LOCATE ** I*4 USRDB$PUT_DUMP ** I*4 USRDB$PUT_FIELD ** I*4 USRDB$PUT_RECORD AP-00000004@ CHAR USRDB$REC ** I*4 USRDB$SQL ** I*4 USRDB$UPDATE_RECORD DBEVL$WHERE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 7 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 RECORDS Address Name Structure Bytes 2-00000000 DBINT USRDB$INTERNAL 1024 AP-00000008@ EVAL$STR EVAL_WHERE 186 RECORD ARRAYS Address Name Structure Bytes Dimensions 2-00000400 EVAL$REC EVAL_WHERE 7068 (38) LABELS Address Label 0-000001C7 5000 FUNCTIONS AND SUBROUTINES REFERENCED Type Name Type Name I*4 LIB$INDEX I*4 USRDB$GET_FIELD OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 8 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0002 OPTIONS/EXTEND 0003 FUNCTION DBEVL$COMPOSE( EVAL$STR ) 0004 C 0005 C *************************************************************************** 0006 C 0007 C ** PURPOSE IS TO PARSE A STRING TO DETERMINE ITS MATCHING CHARACTERISTICS. 0008 C 0009 C *************************************************************************** 0010 C 0011 C ** INCLUDE GLOBAL USERDB DECLARATIONS NEEDED. 0012 C 0013 INCLUDE 'LIFE_DEV:DB_PARAMS.INC/NOLIST' 0158 INCLUDE 'LIFE_DEV:DB_FUNCS.INC/NOLIST' 0179 INCLUDE 'LIFE_DEV:DB_WHERE.INC/NOLIST' 0203 C 0204 C ** SET RETURN STATUS OF THE FUNCTION. 0205 C 0206 DBEVL$COMPOSE = USRDB$_SUCCESS 0207 C 0208 C ** CHECK IF THE FID OF THE STRING IS FOR ACCESS CONTROL, IT CANNOT BE EVALUATED. 0209 C 0210 IF (EVAL$STR.FID .EQ. USRDB$_FID_ACCESS_CONTROL) GOTO 5000 0211 C 0212 C ** DEFINE THE DEFAULT CHARACTERISTICS 0213 C 0214 EVAL$STR.STPNT = 1 0215 EVAL$STR.LENDF = EVAL$STR.FSLEN 0216 EVAL$STR.MATCH = EVAL$STR.FIND(1:EVAL$STR.FSLEN)//' ' 0217 EVAL$STR.MPNTR = 0 0218 C 0219 C ** LOCATE ANY * CHARACTERS IN THE STRING TO BE EVALUATED. 0220 C 0221 LOCBS = INDEX(EVAL$STR.FIND(1:EVAL$STR.FSLEN),'*') 0222 LSTAR = LOCBS + 1 0223 LOCES = INDEX(EVAL$STR.FIND(LSTAR:EVAL$STR.FSLEN),'*') 0224 C 0225 C ** IF ONLY ONE STAR, AND IT IS AFTER FIRST CHARACTER OF THE STRING 0226 C ** TYPE * 0227 C 0228 IF ((LOCBS .GT. 1) .AND. (LOCES .EQ. 0)) THEN 0229 C 0230 C ** DEFINE POINTER, LENGTH OF EVAL STRING, AND THE EVAL STRING. 0231 C 0232 EVAL$STR.MPNTR = 3 0233 EVAL$STR.MATCH = EVaL$STR.FIND(EVAL$STR.STPNT:(LOCBS-1))//' ' 0234 CALL STR$TRIM( EVAL$STR.MATCH, EVAL$STR.MATCH, EVAL$STR.LENDF ) 0235 C 0236 C ** IF ONLY ONE STAR, AND IT IS THE FIRST CHARACTER OF THE STRING. 0237 C ** TYPE * 0238 C 0239 ELSE IF ((LOCBS .EQ. 1) .AND. (LOCES .EQ. 0)) THEN 0240 C 0241 C ** DEFINE POINTER, LENGTH OF EVAL STRING, AND THE EVAL STRING. 0242 C 0243 EVAL$STR.MPNTR = 1 0244 EVAL$STR.LENDF = EVAL$STR.FSLEN - 1 DBEVL$COMPOSE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 9 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0245 EVAL$STR.MATCH = EVAL$STR.FIND(2:EVAL$STR.FSLEN)//' ' 0246 C 0247 C ** TWO STARS IN STRING, TYPE ** 0248 C 0249 ELSE IF ((LOCBS .EQ. 1) .AND. (LOCES .NE. 0)) THEN 0250 C 0251 C ** DEFINE POINTER, LENGTH OF EVAL STRING, AND THE EVAL STRING. 0252 C 0253 EVAL$STR.MPNTR = 2 0254 EVAL$STR.LENDF = EVAL$STR.FSLEN - 2 0255 EVAL$STR.MATCH = EVAL$STR.FIND(2:(EVAL$STR.FSLEN-1))//' ' 0256 C 0257 GOTO 5000 0258 ENDIF 0259 C 0260 C ** CHECK FOR PERCENT IN THE STRING. 0261 C 0262 LOCBA = INDEX(EVAL$STR.FIND(1:EVAL$STR.FSLEN),'%') 0263 C 0264 C ** IF PERCENT IS AT BEGINNING OF STRING. 0265 C 0266 IF (LOCBA .EQ. 1) THEN 0267 C 0268 C ** FIND FIRST CHARACTER NOT A PERCENT 0269 C 0270 EVAL$STR.STPNT = LIB$SKPC(EVAL$STR.FIND, '%') 0271 C 0272 C ** DEFINE POINTER, START OF EVAL STRING, AND THE EVAL STRING. 0273 C 0274 EVAL$STR.MATCH = EVAL$STR.FIND(EVAL$STR.STPNT:EVAL$STR.FSLEN)//' ' 0275 C 0276 IF (EVAL$STR.MPNTR .NE. 0) GOTO 5000 0277 C 0278 EVAL$STR.MPNTR = 3 0279 C 0280 ELSE IF ((LOCBA .GT. 2) .AND. (LOCBS .EQ. 1)) THEN 0281 C 0282 C ** DEFINE POINTER, LENGTH & START OF EVAL STRING, AND THE EVAL STRING. 0283 C 0284 EVAL$STR.MPNTR = 4 0285 EVAL$STR.STPNT = EVAL$STR.LENDF 0286 EVAL$STR.LENDF = LOCBA - 2 0287 EVAL$STR.MATCH = EVAL$STR.FIND(2:EVAL$STR.LENDF)//' ' 0288 C 0289 ENDIF 0290 C 0291 C ** RETURN TO CALLING ROUTINE. 0292 C 0293 5000 RETURN 0294 END DBEVL$COMPOSE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 10 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 832 PIC CON REL LCL SHR EXE RD NOWRT QUAD 1 $PDATA 4 PIC CON REL LCL SHR NOEXE RD NOWRT QUAD 2 $LOCAL 7240 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 8076 ENTRY POINTS Address Type Name 0-00000000 I*4 DBEVL$COMPOSE VARIABLES Address Type Name Address Type Name ** I*4 DBCPY$COPY ** I*4 DBCRS$FIELD_IDENT ** I*4 DBEVL$DEF_SORT ** I*4 DBEVL$LOGICAL ** I*4 DBEVL$PARSE ** I*4 DBEVL$SELECT ** I*4 DBEVL$SORT ** I*4 DBEVL$UPDATE ** I*4 DBEVL$WHERE 2-00001BA0 I*4 LOCBA ** I*4 LOCBS ** I*4 LOCES ** I*4 LSTAR ** I*4 USRDB$CLEAR_RECORD ** I*4 USRDB$DELETE_RECORD ** I*4 USRDB$GET_DUMP ** I*4 USRDB$GET_FIELD ** I*4 USRDB$GET_INIT ** I*4 USRDB$GET_RECORD ** I*4 USRDB$LOCATE ** I*4 USRDB$PUT_DUMP ** I*4 USRDB$PUT_FIELD ** I*4 USRDB$PUT_RECORD ** I*4 USRDB$SQL ** I*4 USRDB$UPDATE_RECORD RECORDS Address Name Structure Bytes AP-00000004@ EVAL$STR EVAL_WHERE 186 RECORD ARRAYS Address Name Structure Bytes Dimensions 2-00000000 EVAL$REC EVAL_WHERE 7068 (38) DBEVL$COMPOSE 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 11 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 LABELS Address Label 0-0000033D 5000 FUNCTIONS AND SUBROUTINES REFERENCED Type Name Type Name Type Name I*4 LIB$INDEX I*4 LIB$SKPC STR$TRIM OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 12 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0002 OPTIONS/EXTEND 0003 FUNCTION DBEVL$LOGICAL( EVAL$REC, ICOUNT ) 0004 C 0005 C *************************************************************************** 0006 C 0007 C ** PURPOSE: TO EVALUATE THE FINAL TRUTH OF THE RECORD SELECTION. 0008 C 0009 C *************************************************************************** 0010 C 0011 C ** INCLUDE GLOBAL USERDB DECLARATIONS NEEDED. 0012 C 0013 INCLUDE 'LIFE_DEV:DB_PARAMS.INC/NOLIST' 0158 INCLUDE 'LIFE_DEV:DB_FUNCS.INC/NOLIST' 0179 INCLUDE 'LIFE_DEV:DB_WHERE.INC/NOLIST' 0203 C 0204 C ** DECLARE LOCAL VARIABLES. 0205 C 0206 LOGICAL EVALUATE(20), BLD_EVAL, DIDEVAL 0207 C 0208 C ** DEFINE FUNCTION VARIABLE VALUE. 0209 C 0210 DBEVL$LOGICAL = USRDB$_FAILURE 0211 C 0212 C ** INITIALIZE THE EVALUATION VARIABLES. 0213 C 0214 ISCAN = 0 0215 DIDEVAL = .FALSE. 0216 C 0217 C ** BEGIN THE LOOPING OF THE WHERE EVALUATIONS. 0218 C 0219 DO II = 1,ICOUNT 0220 C 0221 C ** CHECK FUNCTION, START/WHERE 0222 C 0223 IF (EVAL$REC(II).FUNC .EQ. 'S') THEN 0224 C 0225 C ** INCREMENT SCAN VARIABLE 0226 C 0227 ISCAN = ISCAN + 1 0228 C 0229 C ** PUT VALUE OF EVALUATION INTO ARRAY 0230 C 0231 EVALUATE(ISCAN) = EVAL$REC(II).EVAL 0232 C 0233 C ** IF NOT FIRST WHERE STATEMENT, THEN PLACE EVALUATION INTO FINAL EVALUATION. 0234 C 0235 IF ((ISCAN .EQ. 2) .AND. (.NOT. DIDEVAL)) THEN 0236 C 0237 BLD_EVAL = EVALUATE(1) 0238 C 0239 C ** IF PREVIOUS FINAL EVALUATION, THEN ADD THE NEW EVALUATION. 0240 C 0241 ELSE IF ((ISCAN .GT. 2) .AND. (.NOT. DIDEVAL)) THEN 0242 C 0243 BLD_EVAL = BLD_EVAL .AND. EVALUATE(ISCAN-1) 0244 C DBEVL$LOGICAL 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 13 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0245 C ** FIRST PASS OF LOOP CLAUSE, NO EVALUATION PERFORMED YET. 0246 C 0247 ELSE IF (DIDEVAL) THEN 0248 C 0249 DIDEVAL = .FALSE. 0250 C 0251 ENDIF 0252 C 0253 ELSE IF (EVAL$REC(II).FUNC .EQ. 'A') THEN 0254 C 0255 C ** AN 'AND' OF THE WHERE STATEMENT. 0256 C 0257 EVALUATE(ISCAN) = EVALUATE(ISCAN) .AND. EVAL$REC(II).EVAL 0258 C 0259 C ** AN 'OR' OF THE WHERE STATEMENT 0260 C 0261 ELSE IF (EVAL$REC(II).FUNC .EQ. 'O') THEN 0262 C 0263 C 0264 EVALUATE(ISCAN) = EVALUATE(ISCAN) .OR. EVAL$REC(II).EVAL 0265 C 0266 C ** A 'NEQV' OF THE WHERE STATEMENT 0267 C 0268 ELSE IF (EVAL$REC(II).FUNC .EQ. 'N') THEN 0269 C 0270 C 0271 EVALUATE(ISCAN) = EVALUATE(ISCAN) .NEQV. EVAL$REC(II).EVAL 0272 C 0273 C ** AN 'EQV' OF THE WHERE STATEMENT. 0274 C 0275 ELSE IF (EVAL$REC(II).FUNC .EQ. 'V') THEN 0276 C 0277 C 0278 EVALUATE(ISCAN) = EVALUATE(ISCAN) .EQV. EVAL$REC(II).EVAL 0279 C 0280 C ** WHERE EVALUATION FINISHED. 0281 C 0282 ELSE IF (EVAL$REC(II).FUNC .EQ. 'F') THEN 0283 C 0284 C ** IF ONE PASS, AND TRUE, THEN SUCCESS RETURNED. 0285 C 0286 IF (ISCAN .EQ. 1) THEN 0287 IF (EVALUATE(ISCAN)) DBEVL$LOGICAL = USRDB$_SUCCESS 0288 GOTO 5000 0289 C 0290 C ** IF DONE, AND NO EVALUATION, THEN CHECK THE BUILD EVALUATION VARIABLE FOR TRUTH. 0291 C 0292 ELSE IF (DIDEVAL) THEN 0293 IF (BLD_EVAL) DBEVL$LOGICAL = USRDB$_SUCCESS 0294 GOTO 5000 0295 C 0296 C ** OTHERWISE WE MUST PERFORM LAST EVALUATION AS 'AND', THEN EVALUATE FOR RETURN. 0297 C 0298 ELSE 0299 BLD_EVAL = EVALUATE(ISCAN) .AND. BLD_EVAL 0300 IF (BLD_EVAL) DBEVL$LOGICAL = USRDB$_SUCCESS 0301 GOTO 5000 DBEVL$LOGICAL 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 14 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0302 ENDIF 0303 C 0304 C ** EVALUATE THE PREVIOUS AND CURRENT WHERE CLAUSES USING 'OR'. 0305 C 0306 ELSE IF ((EVAL$REC(II).FUNC .EQ. 'R') .AND. (ISCAN .GT. 1)) THEN 0307 C 0308 DIDEVAL = .TRUE. 0309 C 0310 BLD_EVAL = EVALUATE(ISCAN) .OR. BLD_EVAL 0311 C 0312 C ** EVALUATE THE PREVIOUS AND CURRENT WHERE CLAUSES USING 'NEQV'. 0313 C 0314 ELSE IF ((EVAL$REC(II).FUNC .EQ. 'Q') .AND. (ISCAN .GT. 1)) THEN 0315 C 0316 DIDEVAL = .TRUE. 0317 C 0318 BLD_EVAL = EVALUATE(ISCAN) .NEQV. BLD_EVAL 0319 C 0320 C ** EVALUATE THE PREVIOUS AND CURRENT WHERE CLAUSES USING 'EQV'. 0321 C 0322 ELSE IF ((EVAL$REC(II).FUNC .EQ. 'V') .AND. (ISCAN .GT. 1)) THEN 0323 C 0324 DIDEVAL = .TRUE. 0325 C 0326 BLD_EVAL = EVALUATE(ISCAN) .EQV. BLD_EVAL 0327 C 0328 ENDIF 0329 C 0330 ENDDO 0331 C 0332 C ** RETURN TO CALLING ROUTINE. 0333 C 0334 5000 RETURN 0335 END DBEVL$LOGICAL 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 15 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 500 PIC CON REL LCL SHR EXE RD NOWRT QUAD 2 $LOCAL 300 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 800 ENTRY POINTS Address Type Name 0-00000000 I*4 DBEVL$LOGICAL VARIABLES Address Type Name Address Type Name 2-00000110 L*4 BLD_EVAL ** I*4 DBCPY$COPY ** I*4 DBCRS$FIELD_IDENT ** I*4 DBEVL$COMPOSE ** I*4 DBEVL$DEF_SORT ** I*4 DBEVL$PARSE ** I*4 DBEVL$SELECT ** I*4 DBEVL$SORT ** I*4 DBEVL$UPDATE ** I*4 DBEVL$WHERE ** L*4 DIDEVAL AP-00000008@ I*4 ICOUNT ** I*4 II ** I*4 ISCAN ** I*4 USRDB$CLEAR_RECORD ** I*4 USRDB$DELETE_RECORD ** I*4 USRDB$GET_DUMP ** I*4 USRDB$GET_FIELD ** I*4 USRDB$GET_INIT ** I*4 USRDB$GET_RECORD ** I*4 USRDB$LOCATE ** I*4 USRDB$PUT_DUMP ** I*4 USRDB$PUT_FIELD ** I*4 USRDB$PUT_RECORD ** I*4 USRDB$SQL ** I*4 USRDB$UPDATE_RECORD RECORDS Address Name Structure Bytes 2-00000050 EVAL$STR EVAL_WHERE 186 ARRAYS Address Type Name Bytes Dimensions 2-00000000 L*4 EVALUATE 80 (20) RECORD ARRAYS Address Name Structure Bytes Dimensions AP-00000004@ EVAL$REC EVAL_WHERE 7068 (38) DBEVL$LOGICAL 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 16 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 LABELS Address Label 0-000001EC 5000 OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 17 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0002 OPTIONS/EXTEND 0003 FUNCTION DBCRS$FIELD_IDENT( FIELD_STRING, POINTER ) 0004 C 0005 C *************************************************************************** 0006 C 0007 C ** PURPOSE IS TO LOCATE THE END FIELD FOR THE PASSED FIELD_ID, AND 0008 C ** TO RETURN THE FIELD_ID'S LENGTH. 0009 C 0010 C *************************************************************************** 0011 C 0012 C ** DECLARE LOCAL VARIABLES. 0013 C 0014 CHARACTER FIELD_STRING*(*) 0015 INTEGER*4 POINTER 0016 C 0017 C ** INCLUDE GLOBAL USERDB DECLARATIONS NEEDED. 0018 C 0019 INCLUDE 'LIFE_DEV:DB_PARAMS.INC/NOLIST' 0164 INCLUDE 'LIFE_DEV:DB_FUNCS.INC/NOLIST' 0185 INCLUDE 'LIFE_DEV:DB_CROSS.INC/NOLIST' 0306 C 0307 C ** SET FIELD END POSITION AND LENGTH TO ZERO. 0308 C 0309 DBCRS$FIELD_IDENT = USRDB$_FAILURE 0310 C 0311 C ** GET LENGTH OF THE STRING PASSED. 0312 C 0313 CALL STR$TRIM(FIELD_STRING, FIELD_STRING, LOCLEN ) 0314 C 0315 C ** LOOP THRU THE LIST OF POSSIBLE FIELDS, FIND THE FID OF THE FIELD. 0316 C 0317 DO ICNTR = 1,USRDB$_NUM_FIELDS 0318 C 0319 C ** COMPARE THE FIELDS FOR A MATCH. 0320 C 0321 IF (FIELD_STRING(1:LOCLEN) .EQ. USRDB$_IDENTS(ICNTR)) THEN 0322 POINTER = ICNTR 0323 DBCRS$FIELD_IDENT = USRDB$_SUCCESS 0324 GOTO 2000 0325 ENDIF 0326 C 0327 ENDDO 0328 C 0329 C ** RETURN TO CALLING ROUTINE. 0330 C 0331 2000 RETURN 0332 END DBCRS$FIELD_IDENT 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 18 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 73 PIC CON REL LCL SHR EXE RD NOWRT QUAD 2 $LOCAL 1324 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 1397 ENTRY POINTS Address Type Name 0-00000000 I*4 DBCRS$FIELD_IDENT VARIABLES Address Type Name Address Type Name ** I*4 DBCPY$COPY ** I*4 DBEVL$COMPOSE ** I*4 DBEVL$DEF_SORT ** I*4 DBEVL$LOGICAL ** I*4 DBEVL$PARSE ** I*4 DBEVL$SELECT ** I*4 DBEVL$SORT ** I*4 DBEVL$UPDATE ** I*4 DBEVL$WHERE AP-00000004@ CHAR FIELD_STRING ** I*4 ICNTR 2-00000510 I*4 LOCLEN AP-00000008@ I*4 POINTER ** I*4 USRDB$CLEAR_RECORD ** I*4 USRDB$DELETE_RECORD ** I*4 USRDB$GET_DUMP ** I*4 USRDB$GET_FIELD ** I*4 USRDB$GET_INIT ** I*4 USRDB$GET_RECORD ** I*4 USRDB$LOCATE ** I*4 USRDB$PUT_DUMP ** I*4 USRDB$PUT_FIELD ** I*4 USRDB$PUT_RECORD ** I*4 USRDB$SQL ** I*4 USRDB$UPDATE_RECORD ARRAYS Address Type Name Bytes Dimensions 2-00000000 I*4 USRDB$_CROSS_FID 152 (38) 2-00000098 I*4 USRDB$_CROSS_FLEN 152 (38) 2-000002F8 CHAR USRDB$_DEFAULT 228 (38) 2-0000023A CHAR USRDB$_DMPSTR 190 (38) 2-00000130 CHAR USRDB$_IDENTS 570 (38) LABELS Address Label 0-00000044 2000 DBCRS$FIELD_IDENT 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 19 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 FUNCTIONS AND SUBROUTINES REFERENCED Type Name STR$TRIM OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 20 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0002 OPTIONS/EXTEND 0003 LOGICAL FUNCTION DBUPD$SECURITY( ) 0004 C 0005 C ******************************************************************** 0006 C 0007 C ** PURPOSE: DETERMINE ACCOUNT TYPE FOR DATABASE SECURITY. 0008 C 0009 C ******************************************************************** 0010 C 0011 C ** INCLUDE PARAMETERS FROM SYSTEM. 0012 C 0013 INCLUDE '($JPIDEF)/NOLIST' 0223 C 0224 C ** DEFINE JPI STRUCTURE 0225 C 0226 STRUCTURE /ITMLIST/ ! JPI ITEM LIST 0227 UNION ! WE WILL HAVE 11 ITEMS 0228 MAP ! TO PROMPT FOR. 0229 INTEGER*2 BUFLEN ! 0230 INTEGER*2 CODE ! THE TWELFTH ITEM IS THE 0231 INTEGER*4 BUFADR ! END CODE. 0232 INTEGER*4 RETLENADR ! 0233 END MAP 0234 MAP 0235 INTEGER*4 END_LIST 0236 END MAP 0237 END UNION 0238 END STRUCTURE 0239 RECORD /ITMLIST/ JPILIST(2) 0240 C 0241 C ** DEFINE THE JPI DATA AREA WHICH IS RETURNED 0242 C 0243 CHARACTER*8 INFO_ACCOUNT 0244 INTEGER*4 INFO_ACCOUNT_LENGTH, LENACC 0245 C 0246 C ** DEFINE MISCELLANEOUS VARIABLES 0247 C 0248 INTEGER*4 SYS$GETJPIW 0249 C 0250 C ** SETUP JPI BUFFER 0251 C 0252 JPILIST(01).BUFLEN = 8 0253 JPILIST(01).CODE = (JPI$_ACCOUNT) 0254 JPILIST(01).BUFADR = %LOC(INFO_ACCOUNT) 0255 JPILIST(01).RETLENADR = %LOC(INFO_ACCOUNT_LENGTH) 0256 C 0257 JPILIST(02).END_LIST = 0 0258 C 0259 C ** INITIALIZE SETTING ON THE LOGICAL RETURNED TO MAIN PROGRAM. 0260 C 0261 DBUPD$SECURITY = .FALSE. 0262 C 0263 C ** GET ACCOUNT 0264 C 0265 JPI_RETCODE = SYS$GETJPIW (,,,JPILIST,,,) 0266 C DBUPD$SECURITY 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 21 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0267 C ** TRIM DOWN THE VARIABLES 0268 C 0269 CALL STR$TRIM(INFO_ACCOUNT, INFO_ACCOUNT, LenAcc) 0270 C 0271 C ** CHECK IF THIS IS SYSTEM ACCOUNT. 0272 C 0273 IF (INFO_ACCOUNT(1:LENACC) .EQ. 'SYSTEM') DBUPD$SECURITY = .TRUE. 0274 C 0275 C ** RETURN TO CALLING ROUTINE. 0276 C 0277 RETURN 0278 END PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 93 PIC CON REL LCL SHR EXE RD NOWRT QUAD 1 $PDATA 6 PIC CON REL LCL SHR NOEXE RD NOWRT QUAD 2 $LOCAL 100 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 199 ENTRY POINTS Address Type Name 0-00000000 L*4 DBUPD$SECURITY VARIABLES Address Type Name Address Type Name 2-00000018 CHAR INFO_ACCOUNT 2-00000024 I*4 INFO_ACCOUNT_LENGTH ** I*4 JPI_RETCODE 2-00000028 I*4 LENACC RECORD ARRAYS Address Name Structure Bytes Dimensions 2-00000000 JPILIST ITMLIST 24 (2) FUNCTIONS AND SUBROUTINES REFERENCED Type Name Type Name STR$TRIM I*4 SYS$GETJPIW DBUPD$SECURITY 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 22 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 23 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 0002 OPTIONS/EXTEND 0003 FUNCTION DBCPY$COPY( USRDB$REC, NEWNAME, NWN ) 0004 C 0005 C *************************************************************************** 0006 C 0007 C ** COPY A RECORD TO FORM A NEW RECORD IN THE DATABASE. 0008 C 0009 C *************************************************************************** 0010 C 0011 C ** GET INCLUDE FILES FOR DATABASE OPERATIONS. 0012 C 0013 INCLUDE 'LIFE_DEV:DB_PARAMS.INC/NOLIST' 0158 INCLUDE 'LIFE_DEV:DB_INTERN.INC/NOLIST' 0196 INCLUDE 'LIFE_DEV:DB_FUNCS.INC/NOLIST' 0217 C 0218 C ** DEFINE THE LOCAL VARIABLES. 0219 C 0220 CHARACTER CHK$REC*1024, NEWNAME*12 0221 INTEGER*4 NWN 0222 C 0223 C ** DEFINE FUNCTION RETURN TO BE A FAILURE. 0224 C 0225 DBCPY$COPY = USRDB$_FAILURE 0226 C 0227 C ** CHECK IF AN ENTRY ALREADY EXIST FOR THE FINAL RECORD. 0228 C 0229 ISTAT = USRDB$GET_INIT( CHK$REC, USRDB$_KEY_USER_IDENT, NEWNAME, USRDB$_MATCH_EQ ) 0230 C 0231 C ** CAN'T COPY OVER AN EXISTING RECORD, RETURN TO CALLING ROUTINE. 0232 C 0233 IF (ISTAT .EQ. USRDB$_SUCCESS) RETURN 0234 C 0235 C ** REDEFINE THE PRIMARY KEY OF THE RECORD TO BE WRITTEN TO THE DATABASE. 0236 C 0237 USRDB$REC(1:12) = NEWNAME(1:NWN)//' ' 0238 C 0239 C ** PUT THE RECORD INTO THE DATABASE. 0240 C 0241 ISTAT = USRDB$PUT_RECORD( USRDB$REC ) 0242 C 0243 C ** IF PUT WAS A FAILURE THEN RETURN TO CALLING ROUTINE. 0244 C 0245 IF (ISTAT .EQ. USRDB$_FAILURE ) RETURN 0246 C 0247 C ** DEFINE FUNCTION TO BE A SUCCESS. 0248 C 0249 DBCPY$COPY = USRDB$_SUCCESS 0250 C 0251 C ** RETURN TO CALLING ROUTINE. 0252 C 0253 RETURN 0254 END DBCPY$COPY 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 24 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 PROGRAM SECTIONS Name Bytes Attributes 0 $CODE 103 PIC CON REL LCL SHR EXE RD NOWRT QUAD 1 $PDATA 8 PIC CON REL LCL SHR NOEXE RD NOWRT QUAD 2 $LOCAL 2104 PIC CON REL LCL NOSHR NOEXE RD WRT QUAD Total Space Allocated 2215 ENTRY POINTS Address Type Name 0-00000000 I*4 DBCPY$COPY VARIABLES Address Type Name Address Type Name 2-00000400 CHAR CHK$REC ** I*4 DBCRS$FIELD_IDENT ** I*4 DBEVL$COMPOSE ** I*4 DBEVL$DEF_SORT ** I*4 DBEVL$LOGICAL ** I*4 DBEVL$PARSE ** I*4 DBEVL$SELECT ** I*4 DBEVL$SORT ** I*4 DBEVL$UPDATE ** I*4 DBEVL$WHERE ** I*4 ISTAT AP-00000008@ CHAR NEWNAME AP-0000000C@ I*4 NWN ** I*4 USRDB$CLEAR_RECORD ** I*4 USRDB$DELETE_RECORD ** I*4 USRDB$GET_DUMP ** I*4 USRDB$GET_FIELD ** I*4 USRDB$GET_RECORD ** I*4 USRDB$LOCATE ** I*4 USRDB$PUT_DUMP ** I*4 USRDB$PUT_FIELD AP-00000004@ CHAR USRDB$REC ** I*4 USRDB$SQL ** I*4 USRDB$UPDATE_RECORD RECORDS Address Name Structure Bytes 2-00000000 DBINT USRDB$INTERNAL 1024 FUNCTIONS AND SUBROUTINES REFERENCED Type Name Type Name I*4 USRDB$GET_INIT I*4 USRDB$PUT_RECORD OPTIONS QUALIFIERS /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /EXTEND_SOURCE /F77 /NOG_FLOATING /I4 DBCPY$COPY 22-Mar-1991 18:19:15 VAX FORTRAN V5.5-98 Page 25 01 22-Mar-1991 17:51:53 LQL_DRVR2.FOR;1 COMMAND QUALIFIERS FOR/LIST/SHOW LQL_DRVR2 /CHECK=(NOBOUNDS,OVERFLOW,NOUNDERFLOW) /DEBUG=(NOSYMBOLS,TRACEBACK) /DESIGN=(NOCOMMENTS,NOPLACEHOLDERS) /SHOW=(DICTIONARY,INCLUDE,MAP,PREPROCESSOR,SINGLE) /STANDARD=(NOSEMANTIC,NOSOURCE_FORM,NOSYNTAX) /WARNINGS=(NODECLARATIONS,GENERAL,NOULTRIX,NOVAXELN) /CONTINUATIONS=19 /NOCROSS_REFERENCE /NOD_LINES /NOEXTEND_SOURCE /F77 /NOG_FLOATING /I4 /NOMACHINE_CODE /OPTIMIZE /NOPARALLEL /NOANALYSIS_DATA /NODIAGNOSTICS /LIST=LIB4:[LIFENET.USERDB.CURRENT_SOURCE]LQL_DRVR2.LIS;3 /OBJECT=LIB4:[LIFENET.USERDB.CURRENT_SOURCE]LQL_DRVR2.OBJ;3 COMPILATION STATISTICS Run Time: 8.57 seconds Elapsed Time: 14.13 seconds Page Faults: 1038 Dynamic Memory: 944 pages