LOGICAL FUNCTION USER_HAS_PRIV( PRIV_NAME ) ** * LOGICAL FUNCTION USER_HAS_PRIV( priv_name ) * * * This function returns a value of .TRUE. if this process has the * named privilege (passed as a character string), or returns a value * of .FALSE. if this process does not have the privilege or if the * name is not the name of a known privilege. * * In addition, other information about this process is returned in * in common /USER_DATA_/: * * The PID, process status flags, UIC (longwords), * * The process name, terminal name (if any), user name (strings), * * The lengths of the valid parts of the name strings (words). * * The format of this common block is: * * INTEGER*4 PID,PROC_STAT,UIC * CHARACTER*16 PROCNAME * CHARACTER*8 TERMNAME * CHARACTER*12 USERNAME * INTEGER*2 PNLEN,TNLEN,UNLEN * * COMMON /USER_DATA_/ PID,PROC_STAT,UIC, * 1 PROCNAME,TERMNAME,USERNAME, * 2 PNLEN, TNLEN, UNLEN * * * If you desire to see information in addition to this, you can have * additional data returned by placing your requests in the ITMLST * array in common /USER_PRIV_/. The format of the common block is: * * INTEGER*4 ITMLST(28) * COMMON /USER_PRIV_/ ITMLST * * Your requests may start in ITMLST(22). See the writeup for the * $GETJPI System Service in the VAX/VMS System Services Reference * Manual for the format of the request (each request uses 3 elements * of ITMLST; the last request must be followed by a zero word). You * may define ITMLST to be longer than 28 elements if necessary. * * .INDEX ENVIRONMENT>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Aug 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) PRIV_NAME CHARACTER*6 PRIV CHARACTER*186 PRIVS INTEGER*4 PID,PROC_STAT,UIC CHARACTER*16 PROCNAME CHARACTER*8 TERMNAME CHARACTER*12 USERNAME INTEGER*2 PNLEN,TNLEN,UNLEN COMMON /USER_DATA_/ PID,PROC_STAT,UIC,PROCNAME,TERMNAME,USERNAME, 1 PNLEN, TNLEN, UNLEN PARAMETER ( JPI$_PID = '319'X ) PARAMETER ( JPI$_PRCNAM = '31C'X ) PARAMETER ( JPI$_PROCPRIV = '204'X ) PARAMETER ( JPI$_STS = '305'X) PARAMETER ( JPI$_TERMINAL = '31D'X ) PARAMETER ( JPI$_UIC = '304'X ) PARAMETER ( JPI$_USERNAME = '202'X ) INTEGER*4 ITMLST(28) COMMON /USER_PRIV_/ ITMLST * ITMLST(22) through ITMLST(27) can be set by the calling program * before the first call to USER_HAS_PRIV, to get additional data * about the process. INTEGER*4 PRIVILEGES LOGICAL*1 FIRST_CALL / .TRUE. / DATA PRIVS/'CMKRNLCMEXECSYSNAMGRPNAMALLSPODETACHDIAGNOLOG_IOGROUP 1ACNT PRMCEBPRMMBXPSWAPMALTPRISETPRVTMPMBXWORLD MOUNT OPER EXQUOT 2NETMBXVOLPROPHY_IOBUGCHKPRMGBLSYSGBLPFNMAPSHMEM SYSPRVBYPASSSYSLCK 3'/ IF (FIRST_CALL) THEN FIRST_CALL = .FALSE. CALL ITEM_LIST(ITMLST,JPI$_PID,PID, 1 JPI$_PRCNAM,PROCNAME,PNLEN, 2 JPI$_PROCPRIV,PRIVILEGES, 3 JPI$_STS,PROC_STAT, 4 JPI$_TERMINAL,TERMNAME,TNLEN, 5 JPI$_UIC,UIC, 6 JPI$_USERNAME,USERNAME,UNLEN) STATUS = SYS$GETJPIW(,,,ITMLST,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) UNLEN = STR_LEN(USERNAME) ENDIF PRIV = PRIV_NAME I = INDEX(PRIVS,PRIV) IF (MOD(I,6).NE.1) GO TO 100 IF (PRIVS(I:I+5).NE.PRIV) GO TO 100 USER_HAS_PRIV = IAND(PRIVILEGES,ISHFT(1,I/6)) .NE. 0 RETURN 100 USER_HAS_PRIV = .FALSE. END INTEGER FUNCTION STR_LEN(STRING) ** * INTEGER FUNCTION STR_LEN( string ) * * * Returns, as the functional result, the length of the character * string argument STRING, minus any rightmost blanks and/or tabs. * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 26 Feb 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING STR_LEN = LEN(STRING) DO WHILE (STR_LEN.GT.0) IF ( STRING(STR_LEN:STR_LEN).NE.' ' .AND. 1 STRING(STR_LEN:STR_LEN).NE.CHAR(9) ) RETURN STR_LEN = STR_LEN - 1 ENDDO END INTEGER FUNCTION STR_LEN(STRING) ** * INTEGER FUNCTION STR_LEN( string ) * * * Returns, as the functional result, the length of the character * string argument STRING, minus any rightmost blanks and/or tabs. * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 26 Feb 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING STR_LEN = LEN(STRING) DO WHILE (STR_LEN.GT.0) IF ( STRING(STR_LEN:STR_LEN).NE.' ' .AND. 1 STRING(STR_LEN:STR_LEN).NE.CHAR(9) ) RETURN STR_LEN = STR_LEN - 1 ENDDO END INTEGER FUNCTION SUBINDEX(STRING,COLUMN,PATTERN) ** * INTEGER FUNCTION SUBINDEX ( string , column , pattern ) * * * This is very much like the Fortran INDEX built-in function, except * that SUBINDEX begins the search at an arbitrary column within the * string. * * STRING is the character string to be searched. COLUMN is the col- * umn number at which to begin the search. PATTERN is the substring * for which we are searching. * * The functional result is zero if the pattern is not found in the * string. If the pattern is found, the functional result is set to * the column where the first occurrence of the pattern begins. * * The following example shows a common mistake in using SUBINDEX: * * INCORRECT: COL = SUBINDEX(STRING(22:),22,' ') * * CORRECT: COL = SUBINDEX(STRING,22,' ') * * .INDEX STRING MANIPULATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 16 Feb 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING,PATTERN INTEGER*2 COLUMN SUBINDEX = INDEX(STRING(COLUMN:),PATTERN) IF (SUBINDEX.NE.0) SUBINDEX = SUBINDEX + COLUMN - 1 END INTEGER FUNCTION SD_(PARAM) ** * INTEGER FUNCTION SD_( param ) * * * Accepts a parameter string containing one or more 'SD' type oper- * ations, and computes the resultant device and directory. The op- * erations in the parameter string must be in upper case and must be * separated by one or more blanks. The legal operations are: * * ^ Use directory one subdirectory level up * * ^^ Use master directory at or above current directory * * . Use login default directory and disk * * X Use directory [z.X] when currently in [z.y] * * .X Use directory [current.X] * * X.Y.Z Use directory [X.Y.Z] * * n Use n'th predefined directory (n=0,1,2,...,9) * * * Example: * * If in USER:[A.B], '^ .C' or '>C' or '^^ .C' selects USER:[A.C] * * .INDEX ENVIRONMENT>> * * The resultant device and directory must exist. * * The function result will be one of the following VMS error status * values: * * SS$_NORMAL '00000001'X Success * * RMS$_DIR '000184CC'X Error in directory name (syntax er- * ror or undefined value of n or 0, calling program has already put the current default * device and directory into STRING and SLEN IF (SLEN.EQ.0) CALL DEFAULT_DIRECTORY(STRING,SLEN) CALL SD_SPLIT PLEN = LEN(PARAM) PCOL = 1 10 IF (PCOL.GT.PLEN) THEN CALL SD_TRANSLATE SD_ = SD_EXIST() GO TO 100 ENDIF PCOL2 = SUBINDEX(PARAM,PCOL,' ') IF (PCOL2.EQ.0) THEN PCOL2 = PLEN + 1 ELSE IF (PCOL2.EQ.PCOL) THEN PCOL = PCOL + 1 GO TO 10 ENDIF IF (PARAM(PCOL:PCOL2-1).EQ.'.') THEN CALL LIB$SYS_TRNLOG('SYS$LOGIN',SLEN,STRING) CALL SD_SPLIT ELSE IF (PARAM(PCOL:PCOL).EQ.'.') THEN DIRECTORY(DIRLEN:DIRLEN+PCOL2-PCOL) = PARAM(PCOL:PCOL2-1) 1 // ']' DIRLEN = DIRLEN + PCOL2 - PCOL ELSE IF (PARAM(PCOL:PCOL+1).EQ.'[.') THEN DIRECTORY(DIRLEN:DIRLEN-2+PCOL2-PCOL)= PARAM(PCOL+1:PCOL2-1) DIRLEN = DIRLEN - 2 + PCOL2 - PCOL ELSE IF (PARAM(PCOL:PCOL2-1).EQ.'^^') THEN COL = INDEX(DIRECTORY(1:DIRLEN),'.') IF (COL.NE.0) THEN DIRLEN = COL DIRECTORY(DIRLEN:DIRLEN) = ']' ENDIF ELSE IF (PARAM(PCOL:PCOL2-1).EQ.'^') THEN IF (SD_LASTDOT()) THEN DIRLEN = VALUE DIRECTORY(DIRLEN:DIRLEN) = ']' ENDIF ELSE IF (PARAM(PCOL:PCOL).EQ.'>') THEN IF (SD_LASTDOT()) THEN DIRECTORY(VALUE+1:VALUE+PCOL2-PCOL) = 1 PARAM(PCOL+1:PCOL2-1) // ']' DIRLEN = VALUE + PCOL2 - PCOL ENDIF ELSE IF (PARAM(PCOL:PCOL).EQ.'<') THEN IF (PARAM(PCOL+1:PCOL2).EQ.' ') THEN VALUE = 1 ELSE IF (.NOT.OTS$CVT_TI_L(PARAM(PCOL+1:PCOL2-1),VALUE))THEN GO TO 100 ENDIF VALUE2 = VALUE IF (.NOT.LIB$GET_SYMBOL('SD_SP',STRING,SLEN)) GO TO 100 IF (.NOT.OTS$CVT_TI_L(STRING(1:SLEN),VALUE)) GO TO 100 VALUE = IAND(VALUE-VALUE2,7) IF (.NOT.LIB$GET_SYMBOL('SD_SLOT'// 1 CHAR(VALUE+ICHAR('0')),STRING,SLEN)) GO TO 100 CALL SD_SPLIT ELSE IF (PCOL2.EQ.PCOL+1 .AND. 1 OTS$CVT_TI_L(PARAM(PCOL:PCOL2-1),VALUE)) THEN IF (.NOT.LIB$GET_SYMBOL('SD__'// 1 CHAR(VALUE+ICHAR('0')),STRING,SLEN)) GO TO 100 CALL SD_NEW_DIRECTORY(STRING(1:SLEN),*100) ELSE CALL SD_NEW_DIRECTORY(PARAM(PCOL:PCOL2-1),*100) ENDIF PCOL = PCOL2 + 1 GO TO 10 100 SLEN = 0 END LOGICAL FUNCTION SD_LASTDOT() ** * LOGICAL FUNCTION SD_LASTDOT( ) * * * This routine is not called by the user; it is called by function * SD_ to remove the last subdirectory from a character string con- * taining a directory tree specification. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Oct 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) COMMON /SD_WORK/ VALUE CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY SD_LASTDOT = .FALSE. VALUE = INDEX(DIRECTORY(1:DIRLEN),'.') IF (VALUE.EQ.0) RETURN DO I=VALUE+1,DIRLEN IF (DIRECTORY(I:I).EQ.'.') VALUE = I ENDDO SD_LASTDOT = .TRUE. END INTEGER FUNCTION SD_EXIST() ** * INTEGER FUNCTION SD_EXIST( ) * * * This routine is not called by the user; it is called by function * SD_ to verify that the resultant device and directory actually ex- * ist. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Oct 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*256 STRING COMMON /SD_WORK/ VALUE,SLEN,STRING CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY LOGICAL SD_LASTDOT,SD_EXISTS 1 IF (SD_LASTDOT()) THEN SLEN = DEVLEN + 1 + DIRLEN + 3 STRING(1:SLEN) = DEVICE(1:DEVLEN) // ':' // 1 DIRECTORY(1:DIRLEN-1) // '.DIR' STRING(DEVLEN+1+VALUE:DEVLEN+1+VALUE) = ']' ELSE STATUS = LIB$SYS_TRNLOG(DEVICE(1:DEVLEN),SLEN,STRING) IF (STATUS.EQ.1.AND.STRING(SLEN-1:SLEN).EQ.'.]') THEN VALUE = SLEN - 2 SLEN = VALUE + DIRLEN + 3 STRING(1:SLEN) = STRING(1:VALUE) // ']' // 1 DIRECTORY(2:DIRLEN-1) // '.DIR' ELSE SLEN = DEVLEN + 1 + DIRLEN + 10 STRING(1:SLEN) = DEVICE(1:DEVLEN) // ':[000000]' // 1 DIRECTORY(2:DIRLEN-1) // '.DIR' ENDIF ENDIF INQUIRE (FILE=STRING(1:SLEN),EXIST=SD_EXISTS) IF (.NOT.SD_EXISTS) THEN IF (DEVICE(1:DEVLEN).EQ.'SYS$SYSROOT') THEN DEVLEN = 13 DEVICE(1:DEVLEN) = 'SYS$SYSDEVICE' GO TO 1 ELSE OPEN (1,FILE=STRING(1:SLEN),STATUS='OLD',READONLY,ERR=100) 100 CALL ERRSNS(,STS,SD_EXIST,) IF (SD_EXIST.EQ.0) SD_EXIST = STS IF (SD_EXIST.EQ.'910'X) SD_EXIST = '1C04A'X ENDIF ELSE SD_EXIST = 1 ENDIF END SUBROUTINE SD_NEW_DIRECTORY(STRING,*) ** * SUBROUTINE SD_NEW_DIRECTORY( string , * ) * * * This routine is not called by the user; it is called by function * SD_ to parse a parameter which appears to be a device name and/or * directory name. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Oct 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY CHARACTER*128 WORK LOGICAL TRNLOG * The following is a statement function: TRNLOG() = LIB$SYS_TRNLOG(WORK(1:WLEN),WLEN,WORK) .EQ. 1 WLEN = LEN(STRING) WORK(1:WLEN) = STRING 10 COL = INDEX(WORK(1:WLEN),':') IF (COL.NE.0) THEN ! There is a colon IF (COL.EQ.WLEN) THEN ! Colon is at right end WLEN = WLEN - 1 IF (WLEN.EQ.0) RETURN 1 IF (TRNLOG()) GO TO 10 ! Logical name DEVLEN = WLEN ! Device name DEVICE(1:DEVLEN) = WORK(1:WLEN) RETURN ELSE ! Colon is in the middle DEVLEN = COL - 1 IF (DEVLEN.EQ.0) RETURN 1 DEVICE(1:DEVLEN) = WORK(1:COL-1) WORK(1:WLEN-COL) = WORK(COL+1:WLEN) WLEN = WLEN - COL COL = INDEX(WORK(1:WLEN),'[') IF (COL.NE.0) GO TO 20 ! Directory, with brackets GO TO 30 ! Directory, sans brackets ENDIF ELSE ! There is no colon COL = INDEX(WORK(1:WLEN),'[') IF (COL.NE.0) GO TO 20 ! Directory, with brackets IF (INDEX(WORK(1:WLEN),'.').NE.0) GO TO 30 ! sans brackets IF (TRNLOG()) GO TO 10 ! Logical name GO TO 30 ! Directory, sans brackets ENDIF 20 IF (COL.NE.1 .OR. WORK(WLEN:WLEN).NE.']' .OR. 1 WLEN.EQ.2 .OR. WORK(2:2).EQ.'.') RETURN 1 DIRLEN = WLEN DIRECTORY(1:DIRLEN) = WORK(1:WLEN) RETURN 30 IF (WORK(1:1).EQ.'.') RETURN 1 DIRLEN = WLEN + 2 DIRECTORY(1:DIRLEN) = '[' // WORK(1:WLEN) // ']' END SUBROUTINE SD_SPLIT ** * SUBROUTINE SD_SPLIT * * * This routine is not called by the user; it is called by function * SD_ to split a device/directory specification into separate device * and directory parts. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Oct 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*256 STRING COMMON /SD_WORK/ VALUE,SLEN,STRING CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY COL = INDEX(STRING(1:SLEN),':') DEVLEN = COL - 1 DEVICE(1:DEVLEN) = STRING(1:COL-1) DIRLEN = SLEN - COL DIRECTORY(1:DIRLEN) = STRING(COL+1:SLEN) END SUBROUTINE SD_TRANSLATE ** * SUBROUTINE SD_TRANSLATE * * * This routine is not called by the user; it is called by function * SD_ to attempt to translate any physical device names to site- * specific logical names. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 Oct 1984 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*256 STRING COMMON /SD_WORK/ VALUE,SLEN,STRING CHARACTER*128 DEVICE,DIRECTORY COMMON /SD_LOC/ DEVLEN,DIRLEN,DEVICE,DIRECTORY CHARACTER*256 TNAME IF (LIB$SYS_TRNLOG('SD_TRANS',SLEN,STRING).NE.1) RETURN COL = 1 10 COL2 = SUBINDEX(STRING(1:SLEN),COL,' ') - 1 IF (COL2.LT.0) COL2 = SLEN IF (LIB$SYS_TRNLOG(STRING(COL:COL2),TLEN,TNAME).EQ.1) THEN IF (TNAME(TLEN:TLEN).EQ.':') TLEN = TLEN - 1 COL3 = 1 20 IF (TNAME(COL3:COL3).EQ.'_') THEN COL3 = COL3 + 1 GO TO 20 ENDIF COL4 = 1 30 IF (DEVICE(COL4:COL4).EQ.'_') THEN COL4 = COL4 + 1 GO TO 30 ENDIF IF (DEVICE(COL4:DEVLEN).EQ.TNAME(COL3:TLEN)) THEN DEVLEN = COL2 - COL + 1 DEVICE(1:DEVLEN) = STRING(COL:COL2) RETURN ENDIF ENDIF COL = COL2 + 2 IF (COL.LE.SLEN) GO TO 10 END SUBROUTINE CONTROL_Y(ROUTINE) ** * SUBROUTINE CONTROL_Y( routine ) * * * Sets up linkage for subroutine ROUTINE to get control when ASCII * or is entered to abort this image. The * argument ROUTINE must be declared EXTERNAL in the calling program. * This routine disables CLI interpretation of and , * and sets up an exit handler to re-enable them when the image exits * (this is in case the caller does not do it in ROUTINE, by calling * LIB$ENABLE_CTRL. The exit handler is the separate routine named * CONTROL_Y_EXIT. * * If called with a null argument, the default action of * and are restored. * * 22 Feb 85 Added restoration option. * * .INDEX TERMINAL I/O>> * .INDEX PROCESS CONTROL>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 4 Feb 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) PARAMETER ( IO$_SETMODE = '23'X ) PARAMETER ( IO$M_CTRLYAST = '80'X ) PARAMETER ( IO$M_CTRLCAST = '100'X ) INTEGER*2 CHAN,IOSB(4) EXTERNAL ROUTINE,CONTROL_Y_EXIT COMMON /TT_CHAN_TT/ CHAN DATA CHAN / 0 / IF (CHAN.EQ.0) THEN STATUS = SYS$ASSIGN('TT',CHAN,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE+IO$M_CTRLYAST), 1 IOSB,,,ROUTINE,,,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE+IO$M_CTRLCAST), 1 IOSB,,,ROUTINE,,,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) IF (%LOC(ROUTINE).NE.0) THEN CALL DECLARE_EXIT_HANDLER(CONTROL_Y_EXIT) STATUS = LIB$DISABLE_CTRL('02000000'X) ELSE CALL CANCEL_EXIT_HANDLER(CONTROL_Y_EXIT) STATUS = LIB$ENABLE_CTRL('02000000'X) ENDIF IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) END SUBROUTINE CONTROL_Y_EXIT ** * SUBROUTINE CONTROL_Y_EXIT * * * This routine is not normally called by the user. It is an exit * handler set up by routine CONTROL_Y to re-enable CLI interpreta- * tion of and . See routine CONTROL_Y for details. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 4 Feb 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) STATUS = LIB$ENABLE_CTRL('02000000'X) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) END SUBROUTINE GO_HIBERNATE ** * Subroutines GO_HIBERNATE and GO_WAKE_UP * * * Places the calling process into and out of hibernation. See the * VAX/VMS System Services Reference Manual, Chapter 7 (pages 7-10 * through 7-13) for a discussion of hibernation. * * Note that after the process has been placed in hibernation, the * only ways it can wake up are: * * * If the process receives an AST and the AST routine calls * GO_WAKE_UP (or calls the SYS$WAKE System Service, which * is equivalent) * * * If this process called the SYS$SCHDWK System Service be- * fore it hibernated, to schedule a wake-up call. * * * If another process calls SYS$WAKE or SYS$SCHDWK on be- * half of this process * * .INDEX PROCESS CONTROL>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 2 Apr 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) LOGICAL HIBERNATING COMMON /HIBER_/ HIBERNATING DATA HIBERNATING / .FALSE. / HIBERNATING = .TRUE. STATUS = SYS$HIBER() IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) HIBERNATING = .FALSE. RETURN ENTRY GO_WAKE_UP STATUS = SYS$WAKE(,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) END SUBROUTINE SET_INPUT_ALARM ** * SUBROUTINE SET_INPUT_ALARM * * * Sets things up so that when a character is entered at the caller's * VT100 terminal keyboard, the following things happen: * * * The LOGICAL variable INPUT_READY is set .TRUE. * * * The value of the character entered is put into variable * INPUT_CHAR * * * The variable INPUT_FLAG is set to ' ' (blank) if the * character is a printable character, '*' if it is a con- * trol character, or '.' if it indicates an escape sequen- * ce (i.e. an arrow key or keypad key was hit). In this * last case, INPUT_CHAR contains the last character of the * sequence (for example, if the 'up arrow' key is hit, * INPUT_FLAG is '*' and INPUT_CHAR is 'A'). * * * If the program is hibernating (i.e. it called routine * GO_HIBERNATE) it is wakened up. * * The definition of these variables is: * * LOGICAL*1 INPUT_READY * CHARACTER*1 INPUT_CHAR,INPUT_FLAG * * COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY * * The typed characters are not echoed on the screen; it is up to the * calling program to do this if desired. * * This routine enables a program to be doing useful work at the same * time an input is expected, and, by testing INPUT_READY, the input * can be processed as soon as it occurs. * * When using this routine and the DELETE key is hit, it does not * delete the last character; its ASCII value is placed in INPUT_CHAR * just like any other key. * * This is a one-time enable. After you process the input character, * you must call SET_INPUT_ALARM again to get more input. * * .INDEX TERMINAL I/O>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 30 Apr 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) EXTERNAL INPUT_ALARM INTEGER*2 CHAN,IOSB(4) BYTE BUFFER(16) INTEGER*4 MASK(6) / 16,0,4*'FFFFFFFF'X / LOGICAL*1 INPUT_READY CHARACTER*1 INPUT_CHAR,INPUT_FLAG COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY COMMON /TT_CHAN_TT/ CHAN COMMON /ALARM_IOSB/ IOSB,BUFFER DATA CHAN,INPUT_READY / 0,.FALSE. / PARAMETER ( IO$_READVBLK = '31'X ) PARAMETER ( IO$M_NOECHO = '40'X ) PARAMETER ( IO$M_NOFILTR = '200'X ) PARAMETER ( IO$M_ESCAPE = '4000'X ) PARAMETER ( FUNCTION = IO$_READVBLK + IO$M_NOECHO + 1 IO$M_NOFILTR + IO$M_ESCAPE ) INPUT_READY = .FALSE. IF (CHAN.EQ.0) THEN STATUS=SYS$ASSIGN('TT',CHAN,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF MASK(2)=%LOC(MASK(3)) * NOTE FOLLOWING IS QIO, NOT QIOW! STATUS=SYS$QIO(,%VAL(CHAN),%VAL(FUNCTION),IOSB,INPUT_ALARM,, 1 BUFFER,%VAL(16),,MASK,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) END SUBROUTINE INPUT_ALARM ** * SUBROUTINE INPUT_ALARM * * * This routine is not called by the user. Routine SET_INPUT_ALARM * sets up this routine as the I/O completion AST routine for reading * from the terminal. This routine checks the status of the read, * and parses the input (to set variable INPUT_FLAG). * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 30 Apr 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) EXTERNAL SS$_BADESCAPE INTEGER*2 IOSB(4) BYTE BUFFER(16) LOGICAL*1 INPUT_READY CHARACTER*1 INPUT_CHAR,INPUT_FLAG COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY COMMON /ALARM_IOSB/ IOSB,BUFFER COMMON /HIBER_/ HIBERNATING IF (.NOT.IOSB(1)) THEN IF (IOSB(1).NE.%LOC(SS$_BADESCAPE)) 1 CALL LIB$STOP(%VAL(IOSB(1))) ENDIF INPUT_CHAR = CHAR(BUFFER(IOSB(4))) INPUT_READY = .TRUE. IF (IOSB(3).EQ.'033'O) THEN INPUT_FLAG = '.' ELSE IF (IOSB(3).LT.'040'O.OR.IOSB(3).EQ.'177'O) THEN INPUT_FLAG = '*' ELSE INPUT_FLAG = ' ' ENDIF IF (HIBERNATING) CALL GO_WAKE_UP END SUBROUTINE DECLARE_EXIT_HANDLER(ROUTINE,ARGS) ** * SUBROUTINE DECLARE_EXIT_HANDLER( routine , [arg2] , ... , [arg9] ) * * * Enables an 'exit handler' routine, which is a subroutine provided * by the user, which VMS calls when the image exits. More than one * exit handler can be enabled; at exit time, they are called in rev- * erse order of enabling. Using DECLARE_EXIT_HANDLER, up to ten ex- * it handlers can be enabled. * * Argument ROUTINE is the name of the subroutine to be enabled as an * exit handler. Remember to declare this name EXTERNAL in the call- * ing routine. * * The first argument passed to an exit handler subroutine is always * the longword VMS condition value giving the reason for exit. Up * to eight other arguments can optionally be specified. Remember * that if variables are specified as arguments, values passed will * be the values at program exit time, not the values at the time * DECLARE_EXIT_HANDLER was called. * * If the program decides, before exiting, that an exit handler is * no longer needed, it can call CANCEL_EXIT_HANDLER to tell VMS not * to call the exit handler. * * .INDEX PROCESS CONTROL>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 29 Apr 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) INTEGER*4 DESBLK(12,10),STATUS_ EXTERNAL ROUTINE DATA N / 0 / ! Number of exit handlers declared N = MIN(N+1,10) DESBLK(2,N) = %LOC(ROUTINE) DESBLK(3,N) = MIN(9,NARGS()) DESBLK(4,N) = %LOC(STATUS_) IF (DESBLK(3,N).GT.1) THEN DO I=2,DESBLK(3,N) DESBLK(I+3,N) = ARG_ADDRESS(I) ENDDO ENDIF STATUS_ = SYS$DCLEXH(DESBLK(1,N)) IF (.NOT.STATUS_) CALL LIB$STOP(%VAL(STATUS)) RETURN ENTRY CANCEL_EXIT_HANDLER(ROUTINE) ** * SUBROUTINE CANCEL_EXIT_HANDLER( routine ) * * * Cancels the enabling of an exit handler routine which was previ- * ously enabled by calling routine DECLARE_EXIT_HANDLER. Argument * ROUTINE is the name of the exit handler subroutine to be disabled. * Remember to declare this name EXTERNAL in the calling routine. * * See routine DECLARE_EXIT_HANDLER for more details. * * .INDEX PROCESS CONTROL>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 29 Apr 1985 Dahlgren, Virginia 22448 * DO I=1,N IF (DESBLK(2,I).EQ.%LOC(ROUTINE)) THEN STATUS_ = SYS$CANEXH(DESBLK(1,I)) IF (.NOT.STATUS_) CALL LIB$STOP(%VAL(STATUS)) DESBLK(2,I) = 0 ENDIF ENDDO NEW_N = 0 DO I=1,N IF (DESBLK(2,I).NE.0) NEW_N = I ENDDO N = NEW_N END SUBROUTINE SET_KEYPAD_MODE ** * Subroutines SET_KEYPAD_MODE and RESET_KEYPAD_MODE * * * Places the VT100 keypad keys into or out of Keypad Application * Mode. Normally, the keys are not in application mode; the keypad * '7' for instance, is the same as the keyboard '7', and the 'Enter' * key is the same as 'Return'. When in application mode, the keypad * keys return unique escape sequences, described in the VT100 manual * and reference card. * * The calling program should reset keypad mode before it exits. * * .INDEX TERMINAL I/O>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 2 Apr 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) BYTE BUFFER(2) / 27,0 / INTEGER*2 CHAN,IOSB(4) COMMON /TT_CHAN_TT/ CHAN PARAMETER ( IO$_WRITEVBLK = '30'X ) PARAMETER ( FUNCTION = IO$_WRITEVBLK ) BUFFER(2) = ICHAR('=') 10 IF (CHAN.EQ.0) THEN STATUS=SYS$ASSIGN('TT',CHAN,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF STATUS=SYS$QIOW(,%VAL(CHAN),%VAL(FUNCTION),IOSB,,, 1 BUFFER,%VAL(2),,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) RETURN ENTRY RESET_KEYPAD_MODE BUFFER(2)=ICHAR('>') GO TO 10 END SUBROUTINE SMGL_GET_TERMNL_CHARACTERISTICS ** * SUBROUTINE SMGL_GET_TERMNL_CHARACTERISTICS * * * * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 19 May 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) PARAMETER ( IO$_SENSEMODE = '27'X ) LOGICAL*1 HANDLER_ON INTEGER*2 CHAN,IOSB(4) INTEGER*4 CHARBUF(3) / 3*0 / COMMON /SMGL_CHAR/ CHARBUF,CHAN,IOSB,HANDLER_ON IF (CHAN.EQ.0) THEN STATUS = SYS$ASSIGN('SYS$OUTPUT',CHAN,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE), 1 IOSB,,,CHARBUF,%VAL(12),,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) END SUBROUTINE DEFAULT_DIRECTORY(DIR_STRING,LENGTH) ** * SUBROUTINE DEFAULT_DIRECTORY( dir_string , [ length ] ) * * * Returns, in the character string DIR_STRING, the name of the cur- * rent default device and directory. The string DIR_STRING must be * long enough to contain the name, or this routine will abort. * * If the optional integer*4 argument LENGTH is supplied, then the * length of the name is returned there. * * .INDEX ENVIRONMENT>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 9 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) DIR_STRING LOGICAL ARG_EXIST STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:)) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) LEN1 = LEN1 + LEN2 IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' ' IF (ARG_EXIST(2)) LENGTH = LEN1 END SUBROUTINE MAILBOX(NAME,MB_DATA,INPUT,OUTPUT,PERM,PROT) ** * SUBROUTINE MAILBOX ( name , mb_data , [ input ] , * *+ [ output ] , [perm] , [prot] ) * * * (Part of the NSWC N41 Mailbox-Handling package.) * * Opens a mailbox. The mailbox may already exist; if not, it is * created. If we create it, the mailbox will be a 'Temporary' mail- * box unless the optional argument PERM is included; then it will be * a 'Permanent' mailbox. Note that you must have TMPMBX privilege to * create a temporary mailbox, and PRMMBX privilege to create a perm- * anent mailbox. See below for more information on temporary and * permanent mailboxes. * * The character string argument NAME is the desired logical name of * the mailbox. This logical name must not already be in use by you * (or any other process which will use this mailbox) for any other * purpose. * * The argument MB_DATA must be a four-longword array which is used * by the mailbox routines to store information about the mailbox; * each call to MAILBOX to open a different mailbox must use a dif- * ferent MB_DATA array. This array is always passed as an argument * to routines MAILBOX_READ, MAILBOX_WRITE, and MAILBOX_WRITE_EOF, so * they know which mailbox to use. * * .INDEX MAILBOXES>> * .INDEX INTER-PROCESS COMMUNICATION>> * * The optional argument INPUT is the name of a routine, provided by * you the caller, which will be CALLed when another process which is * using the mailbox writes data to the mailbox. Thus you do not * need to keep testing whether there is anything in the mailbox for * you to read. Remember to declare INPUT as EXTERNAL in the routine * which calls MAILBOX. * * Similarly, the optional argument OUTPUT is the name of a routine, * provided by you the caller, which will be CALLed when another pro- * cess which is using the mailbox attempts to read data from the * mailbox. Thus you do not need to write anything until you know it * is likely to be read. Remember to declare OUTPUT as EXTERNAL in * the routine which calls MAILBOX. * * If you use either or both of these arguments, and you later want * to disable their functions, call MAILBOX again with the same NAME * and MB_DATA arguments, but without the relevent routine name. * Similarly, you can add their functions later after initially not * using them. * * If the mailbox is a 'Temporary' mailbox, it is deleted automatic- * ally by the system when nobody has it open. When the image call- * ing MAILBOX exits, the mailbox is be closed for this process. *- * If the mailbox is 'Permanent', the mailbox will stay in existance * until either the system is shut down, or a process explicitly del- * etes it. Routine MAILBOX_DELETE can be used to delete it. * * If the optional argument PROT is not included, or is zero, anyone * can access the mailbox. The mailbox can be protected by setting * bits in PROT: * R - If bit clear, can READ * bit 15 8 4 0 W - If bit clear, can WRITE * Wrld Grp Ownr Sys L - If bit clear, LOGICAL ACCESS * RWLP RWLP RWLP RWLP P - If bit clear, PHYSICAL ACCESS * * ('P' is apparently not used; LOGICAL ACCESS is necessary to use * INPUT or OUTPUT routines.) * * To actually perform I/O to the mailbox, you use the routines * MAILBOX_READ, MAILBOX_WRITE, and MAILBOX_WRITE_EOF. See them for * details. * * Any message sent must not be longer than 256 bytes. The World (for * a permanent mailbox) or Group (for a temporary mailbox) is permit- * ted to access the mailbox, subject to the PROT argument. * * By default, all mailbox I/O is done in the 'Now' mode; when we do * a WRITE, we do not wait until someone reads what we wrote; when we * do a READ, we get an immediate EOF indication if there is nothing * currently in the mailbox to read. * * If you want to use the opposite 'Wait' mode, you must set bit 31 * of MB_DATA(1) anytime after calling MAILBOX. For example: * * MB_DATA(1) = IOR ( MBDATA(1) , '80000000'X ) * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 5 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) NAME INTEGER*4 MB_DATA(4) LOGICAL ARG_EXIST EXTERNAL INPUT,OUTPUT * MB_DATA(1) = channel assigned to this mailbox, bit 31 on to wait * MB_DATA(2) = routine to call when read is necessary (or zero) * MB_DATA(3) = routine to call when write is necessary (or zero) * MB_DATA(4) = currently unused CHARACTER*32 NAME_,DUMMY INTEGER*2 IOSB(4) LOGICAL LOGICAL_NAME MB_DATA(1) = 0 PRM = 0 ! Temporary IF (ARG_EXIST(5)) PRM = 1 ! Permanent PRT = 0 ! Protection IF (ARG_EXIST(6)) PRT = PROT L = LEN(NAME) CALL STR$UPCASE(NAME_(1:L),NAME) ! Make sure NAME is uppercase IF (.NOT.LOGICAL_NAME(NAME_(1:L))) THEN STATUS = SYS$CREMBX(%VAL(PRM),MB_DATA(1),%VAL(256) 1 ,%VAL(512),%VAL(PRT),,NAME_(1:L)) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ELSE STATUS = SYS$ASSIGN(NAME_(1:L),MB_DATA(1),,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF MB_DATA(2) = 0 MB_DATA(3) = 0 IF (ARG_EXIST(3)) THEN MB_DATA(2) = %LOC(INPUT) CALL MAILBOX_NOTIFY_READ(MB_DATA) ENDIF IF (ARG_EXIST(4)) THEN MB_DATA(3) = %LOC(OUTPUT) CALL MAILBOX_NOTIFY_WRITE(MB_DATA) ENDIF END SUBROUTINE MAILBOX_NOTIFY_READ(MB_DATA) ** * SUBROUTINE MAILBOX_NOTIFY_READ ( mb_data ) * * * (Part of the NSWC N41 Mailbox-Handling package.) * * This routine is not normally called by the user; it is called by * other mailbox routines. See routine MAILBOX for general inform- * ation. * * Sets up a 'Write attention AST' for a mailbox which was opened by * calling Subroutine MAILBOX. This is done when the mailbox is open- * ed, and after every read, if and only if the INPUT argument was * specified on the call to MAILBOX. * * This sets up the linkage for the INPUT routine to be called when * a process puts a record into the mailbox. This is a 'one time' * AST, so it must be done after every read on the mailbox. * * This allows us to know when someone has written to the mailbox, so * we can read the record. * * The argument MB_DATA is the four-longword array for the mailbox of * interest. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 5 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) PARAMETER ( IO$_SETMODE = '23'X ) PARAMETER ( IO$M_READATTN = '80'X ) PARAMETER ( IO$M_WRTATTN = '100'X ) INTEGER*4 MB_DATA(4) INTEGER*2 IOSB(4) FUNC = IO$_SETMODE + IO$M_WRTATTN STATUS = SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,, 1 %VAL(MB_DATA(2)),MB_DATA,,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) RETURN ENTRY MAILBOX_NOTIFY_WRITE(MB_DATA) ** * SUBROUTINE MAILBOX_NOTIFY_WRITE ( mb_data ) * * * (Part of the NSWC N41 Mailbox-Handling package.) * * This routine is not normally called by the user; it is called by * other mailbox routines. See routine MAILBOX for general informa- * tion. * * Sets up a 'Read attention AST' for a mailbox which was opened by * calling Subroutine MAILBOX. This is done when the mailbox is open- * ed, and after every write, if and only if the OUTPUT argument was * specified on the call to MAILBOX. * * This sets up the linkage for the OUTPUT routine to be called when * a process attempts to read a record from the mailbox. This is a * 'one time' AST, so it must be done after every write on the mail- * box. * * This allows us to know whenever someone is reading the mailbox, so * we can provide a record for them to read. * * The argument MB_DATA is the four-longword array for the mailbox of * interest. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 5 Nov 1983 Dahlgren, Virginia 22448 * FUNC = IO$_SETMODE + IO$M_READATTN STATUS = SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,, 1 %VAL(MB_DATA(3)),MB_DATA,,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) END SUBROUTINE MAILBOX_READ(MB_DATA,BUFFER,LENGTH) ** * SUBROUTINE MAILBOX_READ ( mb_data , buffer , length ) * * * (Part of the NSWC N41 Mailbox-Handling package.) * * Reads the next record from a mailbox which was opened by calling * Subroutine MAILBOX. See routine MAILBOX for general information. * * The argument MB_DATA is the four-longword array for the mailbox * you desire to read. BUFFER is the character string into which the * record is read. It must not be shorter than the record, or the * program will abort. The actual length of the record, in bytes, * will be returned in the integer LENGTH; note that it may be zero. * * If an End-of-file is read, LENGTH will be set to minus one (-1). * * See routine MAILBOX for information on the 'Now' and 'Wait' modes. * * .INDEX MAILBOXES>> * .INDEX INTER-PROCESS COMMUNICATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 5 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) PARAMETER ( IO$_READVBLK = '31'X ) PARAMETER ( IO$M_NOW = '40'X ) INTEGER*4 MB_DATA(4) CHARACTER*(*) BUFFER INTEGER*4 LENGTH INTEGER*2 IOSB(4) EXTERNAL SS$_ENDOFFILE FUNC = IO$_READVBLK IF (MB_DATA(1).GT.0) FUNC = FUNC + IO$M_NOW STATUS=SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,, 1 %REF(BUFFER),%VAL(256),,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) THEN IF (IOSB(1).EQ.%LOC(SS$_ENDOFFILE)) THEN LENGTH = -1 ELSE CALL LIB$STOP(%VAL(IOSB(1))) ENDIF ELSE LENGTH = IOSB(2) ENDIF IF (MB_DATA(2).NE.0) CALL MAILBOX_NOTIFY_READ(MB_DATA) END SUBROUTINE MAILBOX_WRITE(MB_DATA,BUFFER) ** * SUBROUTINE MAILBOX_WRITE ( mb_data , buffer ) * * * (Part of the NSWC N41 Mailbox-Handling package.) * * Writes a record to a mailbox which was opened by calling Subrou- * tine MAILBOX. See routine MAILBOX for general information. * * The argument MB_DATA is the four-longword array for the mailbox to * which you desire to write. BUFFER is the character string contain- * ing the data to be written. * * See routine MAILBOX for information on the 'Now' and 'Wait' modes. * * .INDEX MAILBOXES>> * .INDEX INTER-PROCESS COMMUNICATION>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 5 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) PARAMETER ( IO$_WRITEVBLK = '30'X ) PARAMETER ( IO$M_NOW = '40'X ) INTEGER*4 MB_DATA(4) CHARACTER*(*) BUFFER INTEGER*4 LENGTH INTEGER*2 IOSB(4) LENGTH = LEN(BUFFER) FUNC = IO$_WRITEVBLK IF (MB_DATA(1).GT.0) FUNC = FUNC + IO$M_NOW STATUS=SYS$QIOW(,%VAL(MB_DATA(1)),%VAL(FUNC),IOSB,,, 1 %REF(BUFFER),%VAL(LENGTH),,,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) IF (MB_DATA(3).NE.0) CALL MAILBOX_NOTIFY_WRITE(MB_DATA) END INTEGER FUNCTION SEND_MESSAGE(USERNAME,MESSAGE,FLAGS) ** * INTEGER FUNCTION SEND_MESSAGE ( username , message [,flags] ) * * * Sends a message to a given terminal or to a given logged-in user. * The first two arguments are required, and are character strings. * If the first argument contains a colon, it is assumed to be the * name of a terminal, and the message is sent there. For example: * * CALL SEND_MESSAGE('TTA0:',' Hello ') * * In this case, the calling process needs OPER privilege, unless no- * body is logged in at the terminal. * * If the first argument does not contain a colon, it is assumed to * be a person's Username. The message is sent to all terminals (if * any) at which the named user is logged in. For example: * * INTEGER SEND_MESSAGE * * N = SEND_MESSAGE('JONES',' Goodbye ') * * In this case, the calling process needs OPER privilege, and GROUP * privilege if the user is in the same group, or WORLD privilege if * privilege if the user is not in the same group. The function res- * ult is the number of terminals to which the message was sent. * * The message must not be over 256 characters long. * * The optional integer argument FLAGS controls the formatting of the * message. Each bit controls one formatting function: * * Bit 0 -- Ring the recieving terminal's bell four times * * Bit 1 -- Display the message on the recieving terminal in * bold reverse video (valid for VT100 terminals * only). For best readability, the message should * be surrounded by blanks, like in the above exam- * ples. * * If FLAGS is omitted, the default value of 3 is used (ring bell, * display in reverse video). * * .INDEX MESSAGES>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 20 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) USERNAME,MESSAGE CHARACTER*280 BUFFER CHARACTER*1 ESC,BEL CHARACTER*6 FRT CHARACTER*3 BCK CHARACTER*4 BELS PARAMETER ( ESC = CHAR(27) ) PARAMETER ( BEL = CHAR(7) ) PARAMETER ( FRT = ESC//'[1;7m' ) PARAMETER ( BCK = ESC//'[m' ) PARAMETER ( BELS = BEL//BEL//BEL//BEL ) LOGICAL GETJPI,ARG_EXIST,PORT CHARACTER PROC*16,TERM*8,USER*12 INTEGER*2 PNLEN,TNLEN,UNLEN COMMON /GETJPI_1/ PID,STAT,UIC,PROC,TERM,USER,PNLEN,TNLEN,UNLEN FLAGS_ = DEFAULT_ARG(3,'3'X) MLEN = LEN(MESSAGE) BUFFER(1:MLEN) = MESSAGE IF (IAND(FLAGS_,1).NE.0) THEN BUFFER(MLEN+1:MLEN+4) = BELS MLEN = MLEN + 4 ENDIF IF (IAND(FLAGS_,2).NE.0) THEN BUFFER(1:MLEN+9) = FRT // BUFFER(1:MLEN) // BCK MLEN = MLEN + 9 ENDIF SEND_MESSAGE = 0 IF ( INDEX(USERNAME,':') .NE. 0 ) THEN ! Send to given terminal TNLEN = LEN(USERNAME) TERM(1:TNLEN) = USERNAME ASSIGN 30 TO IT GO TO 20 ENDIF ASSIGN 10 TO IT 10 IF ( .NOT. GETJPI(1) ) GO TO 30 IF ( USER(1:UNLEN) .NE. USERNAME ) GO TO 10 20 STATUS = SYS$BRDCST(BUFFER(1:MLEN),TERM(1:TNLEN),,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) SEND_MESSAGE = SEND_MESSAGE + 1 GO TO IT,(10,30) 30 CONTINUE END SUBROUTINE GO_WAIT(SECONDS) ** * SUBROUTINE GO_WAIT ( seconds ) * * * Places the process in a wait state for the specified number of * seconds. The process will show up as being in LEF state in the * SHOW SYSTEM and MONITOR displays. The program will become active * prematurely if an AST occurs. * * .INDEX PROCESS CONTROL>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 14 Nov 1983 Dahlgren, Virginia 22448 * * IMPLICIT INTEGER (A-Z) INTEGER*4 DAYTIME(2) LOGICAL FIRST_CALL / .TRUE. / IF (FIRST_CALL) THEN FIRST_CALL = .FALSE. STATUS = LIB$GET_EF(FLAG) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDIF CALL LIB$EMUL(-SECONDS,10000000,0,DAYTIME) STATUS = SYS$SETIMR(%VAL(FLAG),DAYTIME,,) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SYS$WAITFR(%VAL(FLAG)) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) END SUBROUTINE FILE_ERROR(UNIT) ** * SUBROUTINE FILE_ERROR( [unit] ) * * * Displays one or more error messages associated with the last For- * tran I/O statement executed. This routine should be called after * taking an ERR= branch from an I/O statement. Examples: * * OPEN (1 , ... , ERR=100) * . . . * 100 CALL FILE_ERROR * * * WRITE (1, ... , ERR=200) ... * . . . * 200 CALL FILE_ERROR(8) * * If the optional argument UNIT is omitted, the error messages are * written to the file SYS$OUTPUT; it may also write the messages to * the file SYS$ERROR if SYS$ERROR is assigned to a different file * than SYS$OUTPUT (they normally are the same file) and the error is * severe enough. * * If the optional argument UNIT is specified, it is the Fortran unit * number to which the messages are to be written. The messages are * then written to this file instead of SYS$OUTPUT. NOTE THAT THIS * UNIT NUMBER IS WHERE THE MESSAGES ARE TO BE WRITTEN; IT IS NOT THE * UNIT NUMBER OF THE FILE WHERE THE ERROR OCCURRED. * * In either of the above cases, a blank line is written to the file * before the first line of messages and after the last line. * * .INDEX DISK I/O>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 21 Feb 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) INTEGER*4 MSGVEC(4) / 3,0,0,0 / LOGICAL ARG_EXIST EXTERNAL FILE_ERROR_1 CALL ERRSNS(,MSGVEC(2),MSGVEC(4),) IF (ARG_EXIST(1)) THEN WRITE (UNIT,1000) CALL SYS$PUTMSG(MSGVEC,FILE_ERROR_1,,UNIT) WRITE (UNIT,1000) ELSE PRINT 1000 CALL SYS$PUTMSG(MSGVEC,,,) PRINT 1000 ENDIF 1000 FORMAT (' ') END LOGICAL FUNCTION FILE_ERROR_1(MESSAGE,UNIT) ** * LOGICAL FUNCTION FILE_ERROR_1( message , unit ) * * * This routine is used by subroutine FILE_ERROR and is not called by * user code. * * FILE_ERROR_1 is called by SYS$PUTMSG once for each line of error * message. This routine writes the line to the Fortran unit number * passed as the second argument, and returns a .FALSE. result, which * tells SYS$PUTMSG not to write the line on SYS$OUTPUT or SYS$ERROR. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 21 Feb 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*(*) MESSAGE WRITE (UNIT,1000) MESSAGE FILE_ERROR_1 = .FALSE. 1000 FORMAT (1X,A) END LOGICAL FUNCTION LOGICAL_NAME(NAME) ** * LOGICAL FUNCTION LOGICAL_NAME( name ) * * * Returns a result of .TRUE. if and only if the logical name in the * character string NAME exists. The translation of the name is NOT * returned. * * .INDEX LOGICAL NAMES>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 14 Nov 1983 Dahlgren, Virginia 22448 * * IMPLICIT INTEGER (A-Z) PARAMETER ( LNM$_CASE_BLIND = '02000000'X ) CHARACTER*(*) NAME EXTERNAL SS$_NOLOGNAM STATUS = SYS$TRNLNM(LNM$_CASE_BLIND,'LNM$DCL_LOGICAL',NAME,,) LOGICAL_NAME = STATUS IF (.NOT.STATUS) THEN IF (STATUS.NE.%LOC(SS$_NOLOGNAM)) CALL LIB$STOP(%VAL(STATUS)) ENDIF END LOGICAL FUNCTION FILE_BUSY() ** * LOGICAL FUNCTION FILE_BUSY () * * * When this logical function is called after an unsuccessful attempt * to do a Fortran OPEN on a file, a determination is made whether * the OPEN failed because another user has the file open. If so, we * wait two seconds and return a .TRUE. result, and the calling prog- * ram can retry the OPEN. Otherwise, .FALSE. is returned. * * Usage: * LOGICAL FILE_BUSY * . . . * 10 OPEN (1 , . . . , ERR=100) * . . . * * . . . * 100 IF (FILE_BUSY()) GO TO 10 * . . . * * . . . * * .INDEX DISK I/O>> * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 14 Nov 1983 Dahlgren, Virginia 22448 * * IMPLICIT INTEGER (A-Z) CALL ERRSNS(,STATUS,,,) FILE_BUSY = STATUS .EQ. '1828A'X IF (FILE_BUSY) CALL GO_WAIT(2) END LOGICAL FUNCTION GETJPI( FLAGS , SHOWSUSP ) ** * LOGICAL FUNCTION GETJPI( [ flags ] , [ showsusp ] ) * * * Returns information about all the processes on the system. Infor- * mation about one process is returned each time GETJPI is called. * A function value of .FALSE. is returned after all processes have * been examined; subsequent calls to GETJPI will start the process * scan again at the beginning. * * The optional argument FLAGS may be used to select a class of pro- * cesses to be examined: * * If FLAGS is not present, or is zero, examine all processes * * If FLAGS is one, examine only user interactive processes * * If FLAGS is two, examine only user batch processes * * If FLAGS is three, examine only user interactive and batch * processes * * In addition, if bit 8 of FLAGS is on ('100'X), the process scan is * restarted again at the beginning, even if all processes have not * been examined; only the lower byte of FLAGS is used to select the * class of processes. * * Only if the calling process has WORLD privilege is information * about all processes returned. If the calling process has only * GROUP privilege, then only this group's processes are scanned. If * it has neither WORLD or GROUP privilege, then only THIS process * process and its subprocesses (if any) are scanned. * * .INDEX ENVIRONMENT>> * * The following information is returned in common /GETJPI_1/: * * The PID, process status flags, UIC (longwords), * * The process name, terminal name (if any), user name (strings), * * The lengths of the valid parts of the name strings (words). * * The format of this common block is: * * INTEGER*4 PID,PROC_STAT,UIC * CHARACTER*16 PROCNAME * CHARACTER*8 TERMNAME * CHARACTER*12 USERNAME * INTEGER*2 PNLEN,TNLEN,UNLEN * * COMMON /GETJPI_1/ PID,PROC_STAT,UIC, * 1 PROCNAME,TERMNAME,USERNAME, * 2 PNLEN, TNLEN, UNLEN * *- * If you desire to see information in addition to this, you can have * additional data returned by placing your requests in the ITMLST * array in common /GETJPI_/. The format of the common block is: * * INTEGER*4 ITMLST(25) * COMMON /GETJPI_/ ITMLST * * Your requests may start in ITMLST(19). See the writeup for the * $GETJPI System Service in the VAX/VMS System Services Reference * Manual for the format of the request (each request uses 3 elements * elements of ITMLST; the last request must be followed by a zero * word). You may define ITMLST to be longer than 25 elements if * necessary. * * If you do request additional information, the information you re- * quest may not be available for processes which are suspended or in * MWAIT state. For instance, the image name is not available for * suspended jobs. By default, if you request such information and * the process being examined is suspended or in MWAIT, the process * is ignored; it is as if it did not exist. If you wish to see sus- * pended processes, use the optional argument SHOWSUSP. It must be * an INTEGER*4 or LOGICAL*4 variable; it will be set .TRUE. if the * process is not suspended and not in MWAIT, .FALSE. if suspended or * in MWAIT. * * * 14 Dec 83 Added SHOWSUSP argument. * 14 Mar 85 Use GETJPIW instead of GETJPI * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 18 Nov 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) INTEGER*4 PID,PROC_STAT,UIC CHARACTER*16 PROCNAME CHARACTER*8 TERMNAME CHARACTER*12 USERNAME INTEGER*2 PNLEN,TNLEN,UNLEN COMMON /GETJPI_1/ PID,PROC_STAT,UIC,PROCNAME,TERMNAME,USERNAME, 1 PNLEN, TNLEN, UNLEN PARAMETER ( PCB$V_BATCH = 'E'X ) PARAMETER ( JPI$_PID = '319'X ) PARAMETER ( JPI$_PRCNAM = '31C'X ) PARAMETER ( JPI$_STS = '305'X ) PARAMETER ( JPI$_TERMINAL = '31D'X ) PARAMETER ( JPI$_UIC = '304'X ) PARAMETER ( JPI$_USERNAME = '202'X ) INTEGER*4 ITMLST(25) COMMON /GETJPI_/ ITMLST INTEGER*2 IOSB(4) LOGICAL FIRST_CALL / .TRUE. / LOGICAL ARG_EXIST EXTERNAL SS$_SUSPENDED,SS$_NOPRIV,SS$_NOMOREPROC FLAGS_ = DEFAULT_ARG(1,0) IF (FIRST_CALL.OR.IAND(FLAGS_,'100'X).NE.0) THEN FIRST_CALL = .FALSE. CALL ITEM_LIST(ITMLST,JPI$_PID,PID, 1 JPI$_PRCNAM,PROCNAME,PNLEN, 2 JPI$_STS,PROC_STAT, 3 JPI$_TERMINAL,TERMNAME,TNLEN, 4 JPI$_UIC,UIC, 5 JPI$_USERNAME,USERNAME,UNLEN) PIDADR = -1 ENDIF 10 STATUS = SYS$GETJPIW( , PIDADR , , ITMLST , IOSB , , ) IF (.NOT.STATUS) THEN IF (STATUS.EQ.%LOC(SS$_SUSPENDED)) GO TO 20 IF (STATUS.EQ.%LOC(SS$_NOPRIV)) GO TO 10 IF (STATUS.EQ.%LOC(SS$_NOMOREPROC)) THEN GETJPI = .FALSE. PIDADR = -1 RETURN ENDIF CALL LIB$STOP(%VAL(STATUS)) ENDIF 20 IF (.NOT.IOSB(1)) THEN IF (IOSB(1).EQ.%LOC(SS$_SUSPENDED)) THEN IF (.NOT.ARG_EXIST(2)) GO TO 10 ELSE CALL LIB$STOP(%VAL(IOSB(1))) ENDIF ENDIF GETJPI = .TRUE. UNLEN = STR_LEN(USERNAME) IF (ARG_EXIST(2)) SHOWSUSP = IOSB(1) IF (FLAGS_.EQ.0) RETURN MODE = 0 IF (TNLEN.NE.0) MODE = 1 IF (IAND(PROC_STAT,ISHFT(1,PCB$V_BATCH)).NE.0) MODE = 2 IF (IAND(FLAGS_,MODE).EQ.0) GO TO 10 END