C C BULLETIN0.FOR, Version 10/6/89 C Purpose: Contains subroutines for the bulletin board utility program. C Environment: MIT PFC VAX-11/780, VMS C Programmer: Mark R. London C SUBROUTINE GET_BROADCAST_MESSAGE(RING_BELL) IMPLICIT INTEGER (A-Z) INCLUDE 'bulldir.inc INCLUDE '($BRKDEF)' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT C C The largest message that can be broadcasted is dependent on system C and user quotas. The following limit is 12 lines of ( 80 characters + C CR/LF ) + 2 bells. This should be more than enough room, as broadcasts C shouldn't be too large anyway. C PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) PARAMETER BRDCST_LIMIT = 82*12 + 2 CHARACTER*(BRDCST_LIMIT) BROAD COMMON /BROAD_MESSAGE/ BROAD,BLENGTH IF (RING_BELL) THEN ! Include BELL in message? BROAD(:36) = ! Say who the bulletin is from & BELL//BELL//CR//LF//LF//'NEW BULLETIN FROM: '//FROM BLENGTH = 37 ! Start adding next line here ELSE BROAD(:34) = ! Say who the bulletin is from & CR//LF//LF//'NEW BULLETIN FROM: '//FROM BLENGTH = 35 ! Start adding next line here END IF IF (REMOTE_SET) REWIND (UNIT=3) END = 0 ILEN = LINE_LENGTH + 1 I = I + 1 DO WHILE (ILEN.GT.0) ! Copy bulletin into file IF (REMOTE_SET) THEN READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT IF (IER.NE.0) RETURN ELSE CALL GET_BULL_LINE(NBLOCK+1,LENGTH,INPUT,ILEN) END IF IF (ILEN.GT.0) I = I + 1 IF (ILEN.GT.0.AND.(I.GT.2.OR.(INPUT(:6).NE.'From: '.AND. & INPUT(:6).NE.'Subj: '))) THEN END = BLENGTH + ILEN - 1 + 2 ! Check how long string will be IF (END.GT.BRDCST_LIMIT) RETURN ! String too long? BROAD(BLENGTH:END) = CR//LF//INPUT(:ILEN)! Else add new input BLENGTH = END + 1 ! Reset pointer END IF END DO RETURN ENTRY BROADCAST(ALL,CLUSTER) IF (ALL) THEN ! Should we broadcast to ALL? IF (CLUSTER) THEN CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, & %VAL(BRK$C_ALLTERMS),,,%VAL(BRK$M_CLUSTER),,,,) ELSE CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, & %VAL(BRK$C_ALLTERMS),,,,,,,) END IF ELSE ! Else just broadcast to users. IF (CLUSTER) THEN CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, & %VAL(BRK$C_ALLUSERS),,,%VAL(BRK$M_CLUSTER),,,,) ELSE CALL SYS$BRKTHRU(,BROAD(:BLENGTH-1)//CR,, & %VAL(BRK$C_ALLUSERS),,,,,,,) END IF END IF RETURN END SUBROUTINE GET_FOLDER_INFO(IER) C C SUBROUTINE GET_FOLDER_INFO C C FUNCTION: Obtains & verifies folder names from command line. C IMPLICIT INTEGER (A-Z) INCLUDE 'bullfolder.inc EXTERNAL CLI$_ABSENT COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, & NODE_ERROR,POINT_NODE CHARACTER*32 NODES(10) LOGICAL LOCAL_NODE_FOUND,NODE_ERROR COMMON /ACCESS/ READ_ONLY LOGICAL READ_ONLY CHARACTER NODE_TEMP*256 NODE_NUM = 0 ! Initialize number of nodes DO WHILE (CLI$GET_VALUE('SELECT_FOLDER',NODE_TEMP) & .NE.%LOC(CLI$_ABSENT)) ! Get the specified nodes IER = SYS_TRNLNM(NODE_TEMP,NODE_TEMP) DO WHILE (TRIM(NODE_TEMP).GT.0) NODE_NUM = NODE_NUM + 1 COMMA = INDEX(NODE_TEMP,',') IF (COMMA.GT.0) THEN NODES(NODE_NUM) = NODE_TEMP(:COMMA-1) NODE_TEMP = NODE_TEMP(COMMA+1:) ELSE NODES(NODE_NUM) = NODE_TEMP NODE_TEMP = ' ' END IF NLEN = TRIM(NODES(NODE_NUM)) IF (NODES(NODE_NUM)(NLEN-1:NLEN).EQ.'::') THEN NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN)//'GENERAL' END IF FOLDER_NUMBER = -1 FOLDER1 = NODES(NODE_NUM) CALL SELECT_FOLDER(.FALSE.,IER) IF (.NOT.IER) THEN WRITE (6,'('' Unable to access folder '',A)') & NODES(NODE_NUM) RETURN ELSE IF (READ_ONLY) THEN WRITE (6,'('' ERROR: No write access for folder '',A)') & NODES(NODE_NUM) IER = 0 RETURN END IF END DO END DO IER = 1 RETURN END SUBROUTINE DELETE C C SUBROUTINE DELETE C C FUNCTION: Deletes a bulletin entry from the bulletin file. C IMPLICIT INTEGER (A - Z) COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, & NODE_ERROR,POINT_NODE CHARACTER*32 NODES(10) LOGICAL LOCAL_NODE_FOUND,NODE_ERROR COMMON /DECNET/ DECNET_PROC,ERROR_UNIT LOGICAL DECNET_PROC INCLUDE 'bulldir.inc INCLUDE 'bulluser.inc INCLUDE 'bullfolder.inc COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT EXTERNAL CLI$_ABSENT CHARACTER ANSWER*1,REMOTE_USER*12,SUBJECT*53 INTEGER NOW(2) IMMEDIATE = 0 IF (CLI$PRESENT('IMMEDIATE')) IMMEDIATE = 1 IF (CLI$PRESENT('NODES')) THEN ! Delete messages on DECNET node? CALL DELETE_NODE ! Yes... RETURN ELSE IF (DECNET_PROC) THEN ! Is this from remote node? IER = CLI$GET_VALUE('USERNAME',REMOTE_USER) IER = CLI$GET_VALUE('SUBJECT',SUBJECT,SLEN) CALL STR$UPCASE(SUBJECT,SUBJECT) CALL OPEN_BULLDIR CALL READDIR(0,IER) DEL_BULL = 0 IER = 1 DO WHILE (DEL_BULL+1.EQ.IER) DEL_BULL = DEL_BULL + 1 CALL READDIR(DEL_BULL,IER) CALL STR$UPCASE(DESCRIP,DESCRIP) IF (DEL_BULL+1.EQ.IER.AND.REMOTE_USER.EQ.FROM & .AND.INDEX(DESCRIP,SUBJECT(:SLEN)).GT.0) THEN CALL REMOVE_ENTRY(DEL_BULL,DEL_BULL,DEL_BULL,IMMEDIATE) CALL CLOSE_BULLDIR WRITE (5,'(''END'')') ! Tell DECNET that delete went ok. RETURN END IF END DO CALL CLOSE_BULLDIR ! Specified message not found, WRITE(ERROR_UNIT,1030) ! so error out. RETURN END IF C C Get the bulletin number to be deleted. C IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) ELSE IF (CLI$PRESENT('ALL')) THEN SBULL = 1 EBULL = F_NBULL IER = 0 ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? WRITE(6,1010) ! No, then error. RETURN ELSE SBULL = BULL_POINT ! Delete the file we are reading EBULL = SBULL IER = 0 END IF IF (SBULL.LE.0.OR.IER.NE.0) THEN WRITE (6,1020) RETURN ELSE IF (EBULL.GT.F_NBULL.AND..NOT.REMOTE_SET.AND. & SBULL.NE.EBULL) THEN WRITE (6,'('' Last message specified > number in folder.'')') WRITE (6,'('' Do you want to delete to end of folder? '',$)') READ (5,'(A)',IOSTAT=IER) ANSWER CALL STR$UPCASE(ANSWER,ANSWER) IF (ANSWER.NE.'Y') THEN WRITE (6,'('' Deletion aborted.'')') RETURN ELSE EBULL = F_NBULL END IF END IF C C Check to see if specified bulletin is present, and if the user C is permitted to delete the bulletin. C IF (REMOTE_SET) THEN IF (SBULL.NE.EBULL) THEN WRITE (6,1025) RETURN END IF IF (SBULL.NE.BULL_POINT) CALL READDIR(SBULL,IER) WRITE(REMOTE_UNIT,'(4A)',IOSTAT=IER) & 4,SBULL,IMMEDIATE,DESCRIP IF (IER.EQ.0) THEN READ(REMOTE_UNIT,'(Q,A)',IOSTAT=IER) I,FOLDER1_COM END IF IF (IER.EQ.0) THEN IF (I.EQ.LEN(FOLDER1_COM)) THEN IER = SYS$ASCTIM(,INPUT,F1_NEWEST_BTIM,) NEWEST_EXDATE = INPUT(1:11) NEWEST_EXTIME = INPUT(13:) NBULL = F1_NBULL CALL UPDATE_FOLDER ELSE WRITE (6,'(1X,A)') FOLDER1_COM(:I) END IF ELSE CALL DISCONNECT_REMOTE END IF RETURN END IF CALL OPEN_BULLDIR CALL READDIR(0,IER) DO BULL_DELETE = SBULL,EBULL CALL READDIR(BULL_DELETE,IER) ! Get info for bulletin IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? WRITE(6,1030) ! If not, then error out CALL CLOSE_BULLDIR RETURN END IF IF (USERNAME.NE.FROM) THEN ! If doesn't match owner of bulletin, IF ((.NOT.SETPRV_PRIV().AND..NOT.FOLDER_SET).OR. ! Privileges? & (.NOT.SETPRV_PRIV().AND.USERNAME.NE.FOLDER_OWNER & .AND.FOLDER_SET)) THEN WRITE(6,1040) ! No, then error out. CALL CLOSE_BULLDIR RETURN ELSE IF (SBULL.EQ.EBULL) THEN CALL CLOSE_BULLDIR WRITE (6,1050) ! Make sure user wants to delete it READ (5,'(A)',IOSTAT=IER) ANSWER CALL STR$UPCASE(ANSWER,ANSWER) IF (ANSWER.NE.'Y') RETURN CALL OPEN_BULLDIR CALL READDIR(BULL_DELETE,IER) IF (IER.NE.BULL_DELETE+1) THEN ! Was bulletin found? WRITE(6,1030) ! If not, then error out CALL CLOSE_BULLDIR RETURN END IF END IF END IF C C Delete the bulletin directory entry. C CALL REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) END DO CALL CLOSE_BULLDIR RETURN 1010 FORMAT(' ERROR: You are not reading any message.') 1020 FORMAT(' ERROR: Specified message number has incorrect format.') 1025 FORMAT(' ERROR: Cannot delete multiple messages in remote folder.') 1030 FORMAT(' ERROR: Specified message was not found.') 1040 FORMAT(' ERROR: Message was not deleted. Not owned by you.') 1050 FORMAT(' Message is not owned by you.', & ' Are you sure you want to delete it? ',$) END SUBROUTINE REMOVE_ENTRY(BULL_DELETE,SBULL,EBULL,IMMEDIATE) IMPLICIT INTEGER (A-Z) INCLUDE 'bulldir.inc COMMON /POINT/ BULL_POINT INTEGER NOW(2) IF (IMMEDIATE.EQ.1) THEN ! Delete it immediately CALL DELETE_ENTRY(BULL_DELETE) ! Delete the directory entry IF ((SYSTEM.AND.4).EQ.4) THEN ! Was entry shutdown bulletin? SHUTDOWN = SHUTDOWN - 1 ! Decrement shutdown count END IF ELSE ! Delete it eventually C C Change year of expiration date of message to 100 years less, C to indicate that message is to be deleted. Then, set expiration date C in header of folder to 15 minutes from now. Thus, the folder will be C checked in 15 minutes (or more), and will delete the messages then. C C NOTE: If some comic set their expiration date to > 1999, then C the deleted date will be set to 1899 since can't specify date <1859. C IF (SYSTEM.LE.1) THEN ! General or System message EXDATE = EXDATE(1:7)//'18'//EXDATE(10:) IF (EXDATE(10:10).LT.'6') EXDATE(10:11) = '99' ELSE ! Permanent or Shutdown IF (EXDATE(2:2).EQ.'-') THEN EXDATE = EXDATE(1:6)//'19'//EXDATE(9:) ELSE EXDATE = EXDATE(1:7)//'19'//EXDATE(10:) END IF END IF CALL WRITEDIR(BULL_DELETE,IER) ! Update message expiration date IER = SYS$BINTIM('0 0:15',EX_BTIM) ! Get time 15 minutes from now IER = SYS$GETTIM(NOW) IER = LIB$SUBX(NOW,EX_BTIM,EX_BTIM) IER = SYS$ASCTIM(,INPUT,EX_BTIM,) END IF IF (IMMEDIATE.NE.1.AND.BULL_DELETE.EQ.EBULL) THEN CALL READDIR(0,IER) ! Get header NEWEST_EXDATE = INPUT(1:11) ! and store new expiration date NEWEST_EXTIME = INPUT(13:) CALL WRITEDIR(0,IER) ELSE IF (BULL_DELETE.EQ.EBULL) THEN CALL CLEANUP_DIRFILE(SBULL) ! Reorder directory file CALL UPDATE_ALWAYS ! Somewhat a kludgey way of updating latest ! bulletin and expired dates. IF (SBULL.LE.BULL_POINT) THEN IF (BULL_POINT.GT.EBULL) THEN BULL_POINT = BULL_POINT - (EBULL - SBULL + 1) ELSE BULL_POINT = SBULL END IF END IF ! Readjust where which bulletin to read next ! if deletion causes messages to be moved. END IF RETURN END SUBROUTINE GET_2_VALS(INPUT,ILEN,SVAL,EVAL,IER) IMPLICIT INTEGER (A-Z) CHARACTER*(*) INPUT DELIM = MAX(INDEX(INPUT,':'),INDEX(INPUT,'-')) IF (DELIM.EQ.0) THEN DECODE(ILEN,'(I)',INPUT,IOSTAT=IER) SVAL EVAL = SVAL ELSE DECODE(DELIM-1,'(I)',INPUT,IOSTAT=IER) SVAL IF (IER.EQ.0) THEN ILEN = ILEN - DELIM DECODE(ILEN,'(I)',INPUT(DELIM+1:),IOSTAT=IER) EVAL END IF IF (EVAL.LT.SVAL) IER = 2 END IF RETURN END SUBROUTINE DIRECTORY(DIR_COUNT) C C SUBROUTINE DIRECTORY C C FUNCTION: Display directory of messages. C IMPLICIT INTEGER (A - Z) INCLUDE 'bulldir.inc INCLUDE 'bulluser.inc INCLUDE 'bullfolder.inc COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING LOGICAL PAGING DATA SCRATCH_D1/0/ COMMON /POINT/ BULL_POINT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /TAGS/ BULL_TAG,READ_TAG COMMON /COMMAND_LINE/ INCMD CHARACTER*132 INCMD EXTERNAL CLI$_ABSENT,CLI$_NEGATED,CLI$_PRESENT CHARACTER START_PARAMETER*16,DATETIME*23 INTEGER TODAY(2) CALL LIB$ERASE_PAGE(1,1) ! Clear the screen IF (INCMD(:3).EQ.'DIR'.AND..NOT.READ_TAG) THEN IF (.NOT.CLI$PRESENT('SELECT_FOLDER').AND. & CLI$PRESENT('MARKED')) THEN IF (FOLDER_NUMBER.GE.0) THEN READ_TAG = .TRUE. CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) ELSE WRITE (6,'('' ERROR: Cannot use /MARKED with'', & '' remote folder.'')') RETURN END IF END IF END IF C C Directory listing is first buffered into temporary memory storage before C being outputted to the terminal. This is to be able to quickly close the C directory file, and to avoid the possibility of the user holding the screen, C and thus causing the directory file to stay open. The temporary memory C is structured as a linked-list queue, where SCRATCH_D1 points to the header C of the queue. See BULLSUBS.FOR for more description of the queue. C CALL INIT_QUEUE(SCRATCH_D1,BULLDIR_ENTRY) SCRATCH_D = SCRATCH_D1 CALL OPEN_BULLDIR_SHARED ! Get directory file CALL READDIR(0,IER) ! Does directory header exist? IF (IER.EQ.1.AND.NBULL.GT.0) THEN ! And are there messages? IF (DIR_COUNT.EQ.0) THEN IF (CLI$PRESENT('START')) THEN ! Start number specified? IER = CLI$GET_VALUE('START',START_PARAMETER,ILEN) DECODE(ILEN,'(I)',START_PARAMETER) DIR_COUNT IF (DIR_COUNT.GT.NBULL) THEN DIR_COUNT = NBULL ELSE IF (DIR_COUNT.LT.1) THEN WRITE (6,'('' ERROR: Invalid starting message.'')') CALL CLOSE_BULLDIR DIR_COUNT = 0 RETURN END IF ELSE IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN IF (CLI$PRESENT('SINCE')) THEN ! Was /SINCE specified? IER = CLI$GET_VALUE('SINCE',DATETIME) IF (DATETIME.EQ.'TODAY') THEN ! TODAY is the default. IER = SYS$BINTIM('-- 00:00:00.00',TODAY) CALL GET_MSGKEY(TODAY,MSG_KEY) ELSE CALL SYS_BINTIM(DATETIME,MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) END IF ELSE IF (CLI$PRESENT('NEW')) THEN ! was /NEW specified? DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_BTIM) IF (DIFF.GE.0) THEN WRITE (6,'('' No new messages are present in'', & '' folder '',A,''.'')') FOLDER(:TRIM(FOLDER)) CALL CLOSE_BULLDIR RETURN ELSE CALL GET_MSGKEY(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & MSG_KEY) END IF END IF CALL READDIR_KEYGE(IER) IF (IER.EQ.0) THEN WRITE (6,'('' No messages past specified date.'')') CALL CLOSE_BULLDIR RETURN ELSE DIR_COUNT = IER END IF ELSE DIR_COUNT = BULL_POINT IF (DIR_COUNT.EQ.0) DIR_COUNT = 1 END IF IF (READ_TAG) THEN IF (.NOT.(CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW') & .OR.CLI$PRESENT('START'))) THEN DIR_COUNT = 1 END IF CALL READDIR(DIR_COUNT,IER1) IF (IER1.EQ.DIR_COUNT+1) IER1 = 0 I = 1 DO WHILE (I.LT.9) ITEST = ICHAR(MSG_KEY(I:I)) IF (ITEST.GT.0) THEN MSG_KEY(I:I) = CHAR(ITEST-1) I = 9 ELSE I = I + 1 END IF END DO END IF IF (CLI$PRESENT('SINCE').OR.CLI$PRESENT('NEW')) THEN SBULL = DIR_COUNT EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 IF (EBULL.GE.NBULL-2) EBULL = NBULL ELSE IF (NBULL-DIR_COUNT+1.LE.PAGE_LENGTH-5) THEN EBULL = NBULL SBULL = NBULL - (PAGE_LENGTH-5) + 1 IF (SBULL.LT.1) SBULL = 1 ELSE SBULL = DIR_COUNT EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 END IF ELSE SBULL = DIR_COUNT EBULL = DIR_COUNT + (PAGE_LENGTH - 7) - 1 IF (EBULL.GE.NBULL-2) EBULL = NBULL END IF IF (.NOT.PAGING) THEN EBULL = NBULL END IF IF (.NOT.REMOTE_SET.AND..NOT.READ_TAG) THEN DO I=SBULL,EBULL ! Copy messages from file CALL READDIR(I,IER) ! Into the queue CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) END DO ELSE IF (READ_TAG) THEN I = SBULL DO WHILE (I.LE.EBULL.AND.IER1.EQ.0) CALL GET_NEXT_TAG(FOLDER_NUMBER,IER1,DIR_COUNT) CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) I = I + 1 END DO EBULL = I - 1 IF (IER1.NE.0) EBULL = EBULL - 1 ELSE WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,SBULL,EBULL IF (IER.EQ.0) THEN I = SBULL DO WHILE (IER.EQ.0.AND.I.LE.EBULL) READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY CALL WRITE_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) I = I + 1 END DO END IF IF (IER.NE.0) THEN CALL CLOSE_BULLDIR CALL DISCONNECT_REMOTE RETURN END IF END IF ELSE NBULL = 0 END IF CALL CLOSE_BULLDIR ! We don't need file anymore IF (NBULL.EQ.0) THEN WRITE (6,'('' There are no messages present.'')') RETURN END IF C C Directory entries are now in queue. Output queue entries to screen. C FLEN = TRIM(FOLDER) WRITE(6,'(X,A)') FOLDER(:FLEN) WRITE(6,1000) ! Write header N = 3 IF (BULL_TAG.AND..NOT.READ_TAG) THEN SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) CALL GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) IF (IER.NE.0) NEXT_TAG = NBULL + 1 END IF SCRATCH_D = SCRATCH_D1 ! Init queue pointer to header DO I=SBULL,EBULL CALL READ_QUEUE(%VAL(SCRATCH_D),SCRATCH_D,BULLDIR_ENTRY) CALL CONVERT_ENTRY_FROMBIN IF (MSG_NUM.GT.999) N = 4 IF (MSG_NUM.GT.9999) N = 5 IF (READ_TAG.OR.(BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG)) THEN WRITE (6,'('' *'',$)') ELSE WRITE (6,'('' '',$)') END IF IF (EXDATE(8:9).EQ.'18'.OR.INDEX(EXDATE,'1900').GT.0) THEN WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM,'(DELETED)' ELSE WRITE(6,2010) MSG_NUM,DESCRIP(:55-N),FROM, & DATE(1:7)//DATE(10:11) END IF IF (BULL_TAG.AND.MSG_NUM.EQ.NEXT_TAG) THEN CALL GET_NEXT_TAG(FOLDER_NUMBER,IER,NEXT_TAG) IF (IER.NE.0) NEXT_TAG = NBULL + 1 END IF END DO DIR_COUNT = MSG_NUM + 1 ! Update directory counter IF (DIR_COUNT.GT.NBULL.OR.(READ_TAG.AND.IER1.NE.0)) THEN ! Outputted all entries? DIR_COUNT = 0 ! Yes. Set counter to 0. ELSE WRITE(6,1010) ! Else say there are more END IF RETURN 1000 FORMAT(' #',1X,'Description',43X,'From',9X,'Date',/) 1010 FORMAT(1X,/,' Press RETURN for more...',/) 2010 FORMAT('+',I,1X,A<55-N>,1X,A12,1X,A9) END SUBROUTINE GET_MSGKEY(BTIM,MSG_KEY) IMPLICIT INTEGER (A-Z) INTEGER BTIM(2) CHARACTER*8 MSG_KEY,INPUT CALL LIB$MOVC3(8,BTIM(1),%REF(INPUT)) DO I=1,8 MSG_KEY(I:I) = INPUT(9-I:9-I) END DO RETURN END SUBROUTINE FILE C C SUBROUTINE FILE C C FUNCTION: Copies a bulletin to a file. C IMPLICIT INTEGER (A - Z) COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER INCLUDE 'bulldir.inc INCLUDE 'bullfolder.inc EXTERNAL CLI$_ABSENT IER = CLI$GET_VALUE('BULLETIN_NUMBER',BULL_PARAMETER,LEN_P) IF (IER.NE.%LOC(CLI$_ABSENT)) THEN ! Was bulletin specified? CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) ELSE IF (CLI$PRESENT('ALL')) THEN SBULL = 1 EBULL = F_NBULL IER = 0 ELSE IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? WRITE(6,1010) ! No, then error. RETURN ELSE SBULL = BULL_POINT EBULL = SBULL IER = 0 END IF IF (SBULL.LE.0.OR.IER.NE.0) THEN WRITE (6,1015) RETURN END IF IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P) IF (IER.EQ.%LOC(CLI$_ABSENT)) THEN ! If no file name was specified WRITE(6,1020) ! Write error RETURN ! And return END IF IF (.NOT.SETPRV_PRIV()) THEN ! If no SETPRV, remove SYSPRV CALL DISABLE_PRIVS ! privileges when trying to END IF ! create new file. IF (CLI$PRESENT('NEW')) THEN OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, & RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST') ELSE OPEN(UNIT=3,FILE=BULL_PARAMETER(1:LEN_P),ERR=900, & RECL=LINE_LENGTH, & STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACCESS='APPEND') END IF CALL ENABLE_PRIVS ! Reset SYSPRV privileges HEAD = CLI$PRESENT('HEADER') CALL OPEN_BULLDIR_SHARED CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file DO FBULL = SBULL,EBULL CALL READDIR(FBULL,IER) ! Get info for specified bulletin IF (IER.NE.FBULL+1) THEN ! Was bulletin found? WRITE(6,1030) FBULL IF (FBULL.GT.SBULL) GO TO 100 CLOSE (UNIT=3,STATUS='DELETE') CALL CLOSE_BULLFIL CALL CLOSE_BULLDIR RETURN END IF ILEN = LINE_LENGTH + 1 CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN IF (HEAD) WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8) CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) ELSE IF (HEAD) THEN WRITE(3,1060) FROM,DATE//' '//TIME(:8) END IF IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN IF (HEAD) WRITE(3,1050) INPUT(7:ILEN) ELSE IF (HEAD) WRITE(3,1050) DESCRIP IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN) END IF DO WHILE (ILEN.GT.0) ! Copy bulletin into file CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(1:ILEN) END DO END DO 100 CLOSE (UNIT=3) ! Bulletin copy completed WRITE(6,1040) BULL_PARAMETER(1:LEN_P) ! Show name of file created. CALL CLOSE_BULLFIL CALL CLOSE_BULLDIR RETURN 900 WRITE(6,1000) CALL ENABLE_PRIVS ! Reset BYPASS privileges RETURN 1000 FORMAT(' ERROR: Error in opening file.') 1010 FORMAT(' ERROR: You have not read any bulletin.') 1015 FORMAT(' ERROR: Specified message number has incorrect format.') 1020 FORMAT(' ERROR: No file name was specified.') 1030 FORMAT(' ERROR: Following bulletin was not found: ',I) 1040 FORMAT(' Message(s) written to ',A) 1050 FORMAT('Description: ',A,/) 1060 FORMAT(/,'From: ',A,/,'Date: ',A) END SUBROUTINE LOGIN C C SUBROUTINE LOGIN C C FUNCTION: Alerts user of new messages upon logging in. C IMPLICIT INTEGER (A - Z) INCLUDE 'bulldir.inc INCLUDE 'bulluser.inc INCLUDE 'bullfolder.inc COMMON /READIT/ READIT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING LOGICAL PAGING COMMON /POINT/ BULL_POINT COMMON /PROMPT/ COMMAND_PROMPT CHARACTER*39 COMMAND_PROMPT COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE CHARACTER*1 SEPARATE COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER TODAY*23,INREAD*1 LOGICAL*1 CTRL_G/7/ DATA GEN_DIR1/0/ ! General directory link list header DATA SYS_DIR1/0/ ! System directory link list header DATA SYS_NUM1/0/ ! System message number link list header DATA SYS_BUL1/0/ ! System bulletin link list header DATA ALL_DIR1/0/ ! Full directory link list header (for remote) DATA PAGE/0/ DATA FIRST_WRITE/.TRUE./ LOGICAL FIRST_WRITE DIMENSION NOLOGIN_BTIM(2),LOGIN_BTIM_SAVE(2),TODAY_BTIM(2) DIMENSION NEW_BTIM(2),PASSCHANGE(2),BULLCP_BTIM(2) CALL SYS$ASCTIM(,TODAY,,) ! Get the present time CALL SYS_BINTIM(TODAY,TODAY_BTIM) CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) CALL SYS_BINTIM('5-NOV-1956 11:05:56',NEW_BTIM) C C Find user entry in BULLUSER.DAT to update information and C to get the last date that messages were read. C CALL OPEN_BULLUSER_SHARED CALL MODIFY_SYSTEM_LIST(1) CALL READ_USER_FILE_HEADER(IER) ! Get the header IF (IER.EQ.0) THEN ! Header is present. UNLOCK 4 CALL READ_USER_FILE_KEYNAME(USERNAME,IER1) ! Find if there is an entry IF (NEW_FLAG(1).LT.143.OR.NEW_FLAG(1).GT.143) THEN NEW_FLAG(2)=0 ! If old version clear GENERIC value NEW_FLAG(1)=143 ! Set new version number END IF IF (IER1.EQ.0) THEN ! There is a user entry IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN ! DISMAIL or SET LOGIN set IF (CLI$PRESENT('ALL')) THEN LOGIN_BTIM(1) = TODAY_BTIM(1) LOGIN_BTIM(2) = TODAY_BTIM(2) ELSE RETURN ! Don't notify END IF END IF LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) LOGIN_BTIM(1) = TODAY_BTIM(1) LOGIN_BTIM(2) = TODAY_BTIM(2) REWRITE (4) USER_ENTRY IF (SYSTEM_FLAG(1).NE.0.AND.SYSTEM_FLAG(1).NE.1) READIT = 1 DO I = 1,FLONG IF (SET_FLAG(I).NE.0.OR.BRIEF_FLAG(I).NE.0.OR. & (I.GT.1.AND.SYSTEM_FLAG(I).NE.0)) READIT = 1 END DO ELSE CALL CLEANUP_LOGIN ! Good time to delete dead users READ_BTIM(1) = NEW_BTIM(1) ! Make new entry READ_BTIM(2) = NEW_BTIM(2) DO I = 1,FLONG SET_FLAG(I) = SET_FLAG_DEF(I) BRIEF_FLAG(I) = BRIEF_FLAG_DEF(I) NOTIFY_FLAG(I) = NOTIFY_FLAG_DEF(I) END DO NEW_FLAG(1) = 143 NEW_FLAG(2) = 0 CALL CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) IF (DISMAIL.EQ.1) THEN LOGIN_BTIM(1) = NOLOGIN_BTIM(1) LOGIN_BTIM(2) = NOLOGIN_BTIM(2) LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) ELSE LOGIN_BTIM_SAVE(1) = NEW_BTIM(1) LOGIN_BTIM_SAVE(2) = NEW_BTIM(2) LOGIN_BTIM(1) = TODAY_BTIM(1) LOGIN_BTIM(2) = TODAY_BTIM(2) DO I = 1,FLONG IF (SET_FLAG(I).NE.0) READIT = 1 END DO IF (COMPARE_BTIM(PASSCHANGE,NEWEST_BTIM).LT.0) IER1 = 0 ! Old password change indicates user is new to BULLETIN ! but not to system, so don't limit message viewing. END IF CALL WRITE_USER_FILE(IER) IF (IER.NE.0) THEN ! Error in writing to user file WRITE (6,1070) ! Tell user of the error CALL CLOSE_BULLUSER ! Close the user file CALL EXIT ! Go away... END IF IF (DISMAIL.EQ.1) RETURN ! Go away if DISMAIL set DIFF = -1 ! Force us to look at messages CALL OPEN_BULLINF_SHARED DO I=1,FOLDER_MAX LAST_READ_BTIM(1,I) = READ_BTIM(1) LAST_READ_BTIM(2,I) = READ_BTIM(2) END DO WRITE (9,IOSTAT=IER) USERNAME, & ((LAST_READ_BTIM(I,J),I=1,2),J=1,FOLDER_MAX) CALL CLOSE_BULLINF END IF LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) CALL READ_USER_FILE_HEADER(IER2) ! Reset read back to header END IF IF (IER.EQ.0.AND.MINUTE_DIFF(TODAY_BTIM,BBOARD_BTIM) & .GT.BBOARD_UPDATE) THEN ! Update BBOARD mail? BBOARD_BTIM(1) = TODAY_BTIM(1) BBOARD_BTIM(2) = TODAY_BTIM(2) REWRITE (4) USER_HEADER ! Rewrite header CALL CLOSE_BULLUSER IF (.NOT.TEST_BULLCP()) CALL CREATE_BBOARD_PROCESS ELSE CALL CLOSE_BULLUSER IF (IER.NE.0) CALL EXIT ! If no header, no messages END IF IF (IER1.EQ.0) THEN ! Skip date comparison if new entry C C Compare and see if messages have been added since the last time C that the user has logged in or used the BULLETIN facility. C DIFF1 = COMPARE_BTIM(LOGIN_BTIM,READ_BTIM) IF (DIFF1.LT.0) THEN ! If read messages since last login, LOGIN_BTIM(1) = READ_BTIM(1) ! then use the read date to compare LOGIN_BTIM(2) = READ_BTIM(2) ! with the latest bulletin date END IF ! to see if should alert user. IF (SYSTEM_SWITCH) THEN DIFF1 = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,NEWEST_BTIM) ELSE DIFF1 = COMPARE_BTIM(LOGIN_BTIM,NEWEST_BTIM) END IF END IF LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) ! These are destroyed in UPDATE_READ LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) IF (NEW_FLAG(2).NE.0) THEN CALL LIB$MOVC3(4,NEW_FLAG(2),%REF(BULL_PARAMETER)) CALL SUBTIME(LOGIN_BTIM,BULL_PARAMETER(1:4),IER) ELSE IF (DIFF1.GT.0) THEN BULL_POINT = -1 RETURN END IF C C If there are new messages, look for them in BULLDIR.DAT C Save all new entries in the GEN_DIR file BULLCHECK.SCR so C that we can close BULLDIR.DAT as soon as possible. C ENTRY LOGIN_FOLDER IF (NEW_FLAG(2).EQ.0.OR.FOLDER_SET) THEN LOGIN_BTIM(1) = LOGIN_BTIM_SAVE(1) LOGIN_BTIM(2) = LOGIN_BTIM_SAVE(2) END IF IF (REMOTE_SET) THEN ! If system remote folder, use remote DIFF1 = COMPARE_BTIM(LOGIN_BTIM, ! info, not local login time & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) IF (DIFF1.LT.0) THEN LOGIN_BTIM(1) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) LOGIN_BTIM(2) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) ELSE DIFF = MINUTE_DIFF(LOGIN_BTIM,F_NEWEST_BTIM) IF (DIFF.GE.0.AND.DIFF.LE.15) THEN ! BULLCP updates every 15 min IER = SYS$BINTIM('0 00:15',BULLCP_BTIM) BULLCP_BTIM(1) = -BULLCP_BTIM(1) ! Convert to -delta time BULLCP_BTIM(2) = -BULLCP_BTIM(2)-1 CALL LIB$SUBX(LOGIN_BTIM,BULLCP_BTIM,LOGIN_BTIM) END IF END IF END IF ENTRY SHOW_SYSTEM JUST_SYSTEM = (.NOT.LOGIN_SWITCH.AND.SYSTEM_SWITCH).OR. & (FOLDER_NUMBER.GT.0.AND.BTEST(FOLDER_FLAG,2) & .AND..NOT.TEST2(SET_FLAG,FOLDER_NUMBER) & .AND..NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) NGEN = 0 ! Number of general messages NSYS = 0 ! Number of system messages BULL_POINT = -1 IF (IER1.NE.0.AND.FOLDER_NUMBER.GT.0) RETURN ! Don't overwhelm new user with lots of non-general msgs IF (BTEST(FOLDER_FLAG,2).AND.SYSTEM_SWITCH) THEN ! Can folder have SYSTEM messages and /SYSTEM specified? LOGIN_BTIM(1) = SYSTEM_LOGIN_BTIM(1) ! Use specified login time LOGIN_BTIM(2) = SYSTEM_LOGIN_BTIM(2) ! for system messages. END IF CALL OPEN_BULLDIR_SHARED ! Get bulletin directory IF (.NOT.REMOTE_SET) THEN CALL READDIR(0,IER) ! Get header info ELSE NBULL = F_NBULL END IF CALL INIT_QUEUE(GEN_DIR1,BULLDIR_ENTRY) CALL INIT_QUEUE(SYS_DIR1,BULLDIR_ENTRY) CALL INIT_QUEUE(SYS_NUM1,%DESCR(ICOUNT)) GEN_DIR = GEN_DIR1 SYS_DIR = SYS_DIR1 SYS_NUM = SYS_NUM1 START = 1 REVERSE = 0 IF (REVERSE_SWITCH.AND.(.NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. & .NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER))) THEN REVERSE = 1 IF (IER1.EQ.0) THEN CALL GET_NEWEST_MSG(LOGIN_BTIM,START) IF (START.EQ.-1) START = NBULL + 1 END IF END IF IF (REMOTE_SET) THEN CALL INIT_QUEUE(ALL_DIR1,BULLDIR_ENTRY) IF (REVERSE) THEN WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,START,NBULL ELSE WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER) 13,NBULL,START END IF IF (IER.EQ.0) THEN ALL_DIR = ALL_DIR1 I = START DO WHILE (IER.EQ.0.AND.I.LE.NBULL) READ(REMOTE_UNIT,'(A)',IOSTAT=IER) BULLDIR_ENTRY CALL WRITE_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) I = I + 1 END DO END IF IF (IER.NE.0) THEN CALL CLOSE_BULLDIR CALL DISCONNECT_REMOTE RETURN END IF ALL_DIR = ALL_DIR1 END IF DO ICOUNT1 = NBULL,START,-1 IF (REVERSE) THEN ICOUNT = NBULL + START - ICOUNT1 ELSE ICOUNT = ICOUNT1 END IF IF (REMOTE_SET) THEN CALL READ_QUEUE(%VAL(ALL_DIR),ALL_DIR,BULLDIR_ENTRY) IER = ICOUNT + 1 ELSE CALL READDIR(ICOUNT,IER) END IF IF (IER1.EQ.0.AND.IER.EQ.ICOUNT+1) THEN ! Is this a totally new user? ! No. Is bulletin system or from same user? IF (.NOT.REVERSE) THEN DIFF = COMPARE_BTIM(LOGIN_BTIM,MSG_BTIM) ! No, so compare date IF (DIFF.GT.0) GO TO 100 END IF IF (.NOT.BTEST(FOLDER_FLAG,2)) SYSTEM = SYSTEM.AND.(.NOT.1) ! Show system msg in non-system folder as general msg IF (USERNAME.NE.FROM.OR.SYSTEM) THEN IF (SYSTEM) THEN ! Is it system bulletin? NSYS = NSYS + 1 CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) ELSE IF (.NOT.JUST_SYSTEM) THEN IF (SYSTEM_SWITCH) THEN DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,MSG_BTIM) ELSE DIFF = -1 END IF IF (DIFF.LT.0) THEN IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN BULL_POINT = ICOUNT - 1 IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 END IF NGEN = NGEN + 1 SYSTEM = ICOUNT CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) END IF END IF END IF ELSE IF (IER.EQ.ICOUNT+1) THEN ! Totally new user, save only permanent system msgs IF (SYSTEM.EQ.3) THEN NSYS = NSYS + 1 CALL WRITE_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) CALL WRITE_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) ELSE IF (NGEN.EQ.0) THEN ! And save only the first non-system msg SYSTEM = ICOUNT ! Save bulletin number for display IF (.NOT.REVERSE.OR.BULL_POINT.EQ.-1) THEN BULL_POINT = ICOUNT - 1 IF (TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. & TEST2(SET_FLAG,FOLDER_NUMBER)) GO TO 100 END IF NGEN = NGEN + 1 CALL WRITE_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) END IF END IF END DO 100 CALL CLOSE_BULLDIR C C Review new directory entries. If there are system messages, C copy the system bulletin into GEN_DIR file BULLSYS.SCR for outputting C to the terminal. If there are simple messages, just output the C header information. C IF (NGEN.EQ.0.AND.NSYS.EQ.0) RETURN IF (NSYS.GT.0) THEN ! Are there any system messages? IF (FIRST_WRITE) THEN PAGE = 4 ! Don't erase MAIL/PASSWORD notifies FIRST_WRITE = .FALSE. ! if this is first write to screen. END IF LENF = TRIM(FOLDER) S1 = (PAGE_WIDTH-(LENF+16))/2 S2 = PAGE_WIDTH - S1 - (LENF + 16) WRITE (6,'(''+'',A,$)') CTRL_G WRITE (6,1026) FOLDER(:LENF) ! Yep... PAGE = PAGE + 1 CTRL_G = 0 ! Don't ring bell for non-system bulls CALL OPEN_BULLFIL_SHARED CALL INIT_QUEUE(SYS_BUL1,INPUT) SYS_BUL = SYS_BUL1 SYS_DIR = SYS_DIR1 SYS_NUM = SYS_NUM1 NSYS_LINE = 0 DO J=1,NSYS CALL READ_QUEUE(%VAL(SYS_DIR),SYS_DIR,BULLDIR_ENTRY) IF (REMOTE_SET) THEN CALL READ_QUEUE(%VAL(SYS_NUM),SYS_NUM,%DESCR(ICOUNT)) WRITE (REMOTE_UNIT,'(2A)',IOSTAT=IER) 5,ICOUNT IF (IER.GT.0) THEN CALL DISCONNECT_REMOTE ELSE CALL GET_REMOTE_MESSAGE(IER) END IF IF (IER.GT.0) THEN CALL CLOSE_BULLFIL RETURN END IF END IF INPUT = ' ' CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) NSYS_LINE = NSYS_LINE + 1 ILEN = LINE_LENGTH + 1 CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) END IF IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) END IF DO WHILE (ILEN.GT.0) ! Copy bulletin to SYS_BUL link list CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) NSYS_LINE = NSYS_LINE + 1 CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) END DO IF (ILEN.LT.0) THEN CALL CLOSE_BULLFIL RETURN END IF IF (J.LT.NSYS.AND.SEPARATE.NE.' ') THEN INPUT = ' ' CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) DO I=1,PAGE_WIDTH INPUT(I:I) = SEPARATE END DO CALL WRITE_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) NSYS_LINE = NSYS_LINE + 2 END IF END DO CALL CLOSE_BULLFIL SYS_BUL = SYS_BUL1 ILEN = 0 I = 1 DO WHILE (I.LE.NSYS_LINE.OR.ILEN.GT.0) ! Write out system messages IF (ILEN.EQ.0) THEN CALL READ_QUEUE(%VAL(SYS_BUL),SYS_BUL,INPUT) ILEN = TRIM(INPUT) I = I + 1 END IF IF (SYS_BUL.NE.0) THEN IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen WRITE(6,1080) ! Ask for input to proceed to next page CALL GET_INPUT_NOECHO_PROMPT(INREAD,! Get terminal input & 'HIT any key for next page....') CALL LIB$ERASE_PAGE(1,1) ! Clear the screen PAGE = 1 IF (ILEN.LE.PAGE_WIDTH) THEN WRITE(6,1060) '+'//INPUT(:ILEN) ILEN = 0 ELSE WRITE(6,1060) '+'//INPUT(:PAGE_WIDTH) INPUT = INPUT(PAGE_WIDTH+1:) ILEN = ILEN - PAGE_WIDTH END IF ELSE PAGE = PAGE + 1 IF (ILEN.LE.PAGE_WIDTH) THEN WRITE(6,1060) ' '//INPUT(:ILEN) ILEN = 0 ELSE WRITE(6,1060) ' '//INPUT(:PAGE_WIDTH) INPUT = INPUT(PAGE_WIDTH+1:) ILEN = ILEN - PAGE_WIDTH END IF END IF END IF END DO IF (NGEN.EQ.0) THEN WRITE(6,'(A)') ! Write delimiting blank line END IF PAGE = PAGE + 1 END IF ENTRY REDISPLAY_DIRECTORY GEN_DIR = GEN_DIR1 IF (NGEN.GT.0) THEN ! Are there new non-system messages? LENF = TRIM(FOLDER) S1 = (PAGE_WIDTH-13-LENF)/2 S2 = PAGE_WIDTH-S1-13-LENF IF (PAGE+5+NGEN.GT.PAGE_LENGTH.AND.PAGE.GT.0) THEN WRITE(6,1080) ! Ask for input to proceed to next page CALL GET_INPUT_NOECHO_PROMPT(INREAD, ! Get terminal input & 'HIT any key for next page....') CALL LIB$ERASE_PAGE(1,1) ! Clear the screen WRITE (6,'(''+'',A,$)') CTRL_G WRITE(6,1028) 'New '//FOLDER(1:LENF)//' messages' PAGE = 1 ELSE IF (FIRST_WRITE) THEN PAGE = 4 ! Don't erase MAIL/PASSWORD notifies FIRST_WRITE = .FALSE. ! if this is first write to screen. END IF WRITE (6,'(''+'',A,$)') CTRL_G WRITE(6,1027) 'New '//FOLDER(1:LENF)//' messages' PAGE = PAGE + 1 END IF WRITE(6,1020) WRITE(6,1025) PAGE = PAGE + 2 I = 0 DO WHILE (I.LT.NGEN) I = I + 1 CALL READ_QUEUE(%VAL(GEN_DIR),GEN_DIR,BULLDIR_ENTRY) CALL CONVERT_ENTRY_FROMBIN IF (SYSTEM.GT.9999) THEN ! # Digits in message number N = 5 ELSE IF (SYSTEM.GT.999) THEN N = 4 ELSE N = 3 END IF IF (PAGE.EQ.PAGE_LENGTH-2.AND.PAGING) THEN ! If at end of screen WRITE(6,1080) ! Ask for input to proceed to next page CALL GET_INPUT_NOECHO_PROMPT(INREAD, & 'HIT Q(Quit listing) or any other key for next page....') CALL STR$UPCASE(INREAD,INREAD) CALL LIB$ERASE_PAGE(1,1) ! Clear the screen PAGE = 1 IF (INREAD.EQ.'Q') THEN I = NGEN ! Quit directory listing WRITE(6,'(''+Quitting directory listing.'')') ELSE WRITE(6,1040) '+'//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM END IF ! Bulletin number is stored in SYSTEM ELSE PAGE = PAGE + 1 WRITE(6,1040) ' '//DESCRIP(:56-N),FROM,DATE(:6),SYSTEM END IF END DO IF ((.NOT.FOLDER_SET.AND.BTEST(SET_FLAG(1),0).AND.DIFF1.LE.0) & .OR.(FOLDER_SET.AND.TEST2(SET_FLAG,FOLDER_NUMBER))) THEN PAGE = 0 ! Don't reset page counter if READNEW not set, END IF ! as no prompt to read is generated. END IF C C Instruct users how to read displayed messages if READNEW not selected. C IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. & TEST2(SET_FLAG,FOLDER_NUMBER)) THEN WRITE(6,1030) ELSE IF (NGEN.EQ.0) THEN ILEN = 57 + INDEX(COMMAND_PROMPT,'>') - 1 S1 = (PAGE_WIDTH-ILEN)/2 S2 = PAGE_WIDTH - S1 - ILEN WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-57)// & '/SYSTEM command can be used to reread these messages.' ELSE FLEN = TRIM(FOLDER) IF (FOLDER_NUMBER.EQ.0) FLEN = -1 ILEN = 49 + INDEX(COMMAND_PROMPT,'>') - 1 + FLEN S1 = (PAGE_WIDTH-ILEN)/2 S2 = PAGE_WIDTH - S1 - ILEN IF (FOLDER_NUMBER.EQ.0) THEN WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-48)// & ' command can be used to read these messages.' ELSE WRITE(6,1035) 'The '//COMMAND_PROMPT(:ILEN-49-FLEN) & //' '//FOLDER(:FLEN)// & ' command can be used to read these messages.' END IF END IF RETURN 1020 FORMAT(' Description',43X,'From',9X,'Date',3X,'Number') 1025 FORMAT(' -----------',43X,'----',9X,'----',3X,'------') 1026 FORMAT(' ',('*'),A,' System Messages',('*')) 1027 FORMAT(/,' ',('*'),A,('*')) 1028 FORMAT('+',('*'),A,('*')) 1030 FORMAT(' ',('*')) 1035 FORMAT(' ',('*'),A,('*')) 1040 FORMAT(A<57-N>,1X,A12,1X,A6,<6-N>X,I) 1060 FORMAT(A) 1070 FORMAT(' ERROR: Cannot add new entry to user file.') 1080 FORMAT(' ',/) END SUBROUTINE GET_NODE_NUMBER_OTHER(NODE_NUMBER,NODE_AREA,NODE_NAME) IMPLICIT INTEGER (A-Z) INCLUDE '($SYIDEF)' CHARACTER*(*) NODE_NAME CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST(4,SYI$_NODE_AREA,%LOC(NODE_AREA)) CALL ADD_2_ITMLST(4,SYI$_NODE_NUMBER,%LOC(NODE_NUMBER)) CALL END_ITMLST(GETSYI_ITMLST) ! Get address of itemlist IER = SYS$GETSYIW(,,NODE_NAME(:TRIM(NODE_NAME)), & %VAL(GETSYI_ITMLST),,,) ! Get Info command. IF (.NOT.IER) THEN WRITE (6,'('' ERROR: Specified node name not found.'')') NODE_AREA = 0 END IF RETURN END