PROGRAM SD ** * SET/SHOW DEFAULT DIRECTORY * * * Inputs: DCL Symbol PARAM * Current default device/directory * * Outputs: DCL Symbol CHANGE \__ (Not set if * DCL Symbol COMMAND / error occurs) * (Current default device/directory unchanged) * * * Alan L. Zirkle Naval Surface Weapons Center * Code K53 * Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY CHARACTER*256 STRING COMMON /SD_WORK/ VALUE,EXPDEV,SLEN,STRING CHARACTER*256 DEFAULT,COMMAND,PARAM COMMON /SD_COMMAND/ PLEN,CLEN,PARAM,COMMAND LOGICAL PRIV,USER_HAS_PRIV CHARACTER*5 SGS_VERSION DATA CLEN,COMMAND / 4,'EXIT' / STATUS = LIB$GET_SYMBOL('PARAM',PARAM,PLEN) PLEN = STR_LEN(PARAM(1:PLEN)) IF (.NOT.STATUS .OR. PLEN.EQ.0) CALL ERROR(1) IF (PARAM(1:PLEN).EQ.'$') THEN sgs_version = '3.0' L = STR_LEN(SGS_VERSION) CALL LIB$PUT_LINE(' SD.EXE Version '//SGS_VERSION(1:L)// 1 ' ',,2) CALL EXIT ENDIF CALL CHECK_COMMAND('*','TREE') CALL CHECK_COMMAND('<<','STACK') CALL CHECK_COMMAND(' DIR','DIR') IF (PLEN.EQ.0) GO TO 10 CALL DEFAULT_DIRECTORY(DEFAULT,DLEN) SLEN = DLEN STRING(1:SLEN) = DEFAULT(1:DLEN) PRIV = USER_HAS_PRIV('SYSPRV') STATUS = SD_(PARAM(1:PLEN),PRIV) IF (.NOT.STATUS) THEN IF (STATUS.EQ.'184CC'X) CALL ERROR(3) ! Bad directory name IF (STATUS.EQ.'1C04A'X) CALL ERROR(4) ! No such directory IF (STATUS.EQ.'00024'X) CALL ERROR(5) ! No privilege IF (STATUS.EQ.'00908'X) CALL ERROR(6) ! No such device IF (STATUS.EQ.'00930'X) CALL ERROR(7) ! No more files ENDIF DEVICE(DEVLEN+1:DEVLEN+DIRLEN) = DIRECTORY(1:DIRLEN) DEVLEN = DEVLEN + DIRLEN IF (DEVICE(1:DEVLEN).NE.DEFAULT(1:DLEN)) THEN STATUS = LIB$SET_SYMBOL('CHANGE',DEVICE(1:DEVLEN)) ELSE 10 STATUS = LIB$SET_SYMBOL('CHANGE',' ') ENDIF IF (.NOT.STATUS) CALL ERROR(2,STATUS) STATUS = LIB$SET_SYMBOL('COMMAND',COMMAND(1:CLEN)) IF (.NOT.STATUS) CALL ERROR(2,STATUS) END SUBROUTINE CHECK_COMMAND(KEY_STRING,COMMAND_STRING) IMPLICIT INTEGER (A-Z) CHARACTER*(*) KEY_STRING,COMMAND_STRING CHARACTER*256 COMMAND,PARAM COMMON /SD_COMMAND/ PLEN,CLEN,PARAM,COMMAND COL = INDEX(PARAM(1:PLEN),KEY_STRING) - 1 IF (COL.LT.0) RETURN CALL LIB$SET_SYMBOL('REST',PARAM(COL+LEN(KEY_STRING)+1:PLEN)) PLEN = STR_LEN(PARAM(1:COL)) CLEN = LEN(COMMAND_STRING) COMMAND(1:CLEN) = COMMAND_STRING END SUBROUTINE ERROR(CODE,STATUS) IMPLICIT INTEGER (A-Z) CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY CHARACTER*2 B PARAMETER ( B = CHAR(7) // CHAR(7) ) CALL LIB$PUT_LINE(' ') GO TO (1,2,3,4,5,6,7),CODE 1 CALL LIB$PUT_LINE(' Syntax Error '//B,2,3) GO TO 100 2 CALL LIB$PUT_LINE(' Error defining symbols '//B,2,3) CALL LIB$STOP(%VAL(STATUS)) 3 CALL LIB$PUT_LINE(' Invalid Directory Name '//B,2,3) GO TO 100 4 CALL LIB$PUT_LINE(' No Such Directory '//DIRECTORY(1:DIRLEN) 1 //' on '//DEVICE(1:DEVLEN)//' '//B,2,3) GO TO 100 5 CALL LIB$PUT_LINE(' No Privilege To Use '//DIRECTORY(1:DIRLEN) 1 //' '//B,2,3) GO TO 100 6 CALL LIB$PUT_LINE(' Device '//DEVICE(1:DEVLEN) 1 //' Not Available '//B,2,3) GO TO 100 7 CALL LIB$PUT_LINE(' End of traversal reached '//B,2,3) 100 CALL EXIT('10000004'X) ! Abort, without a message END