C C BULLETIN7.FOR, Version 8/14/97 C Purpose: Contains subroutines for the BULLETIN utility program. C Environment: VAX/VMS C Programmer: Mark R. London C C Copyright (c) 1990 C Property of Massachusetts Institute of Technology, Cambridge MA 02139. C This program cannot be copied or distributed in any form for non-MIT C use without specific written approval of MIT Plasma Fusion Center C Management. C SUBROUTINE UPDATE_LOGIN(ADD_BULL) C C SUBROUTINE UPDATE_LOGIN C C FUNCTION: Updates the login file when a bulletin has been deleted C or added. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE '($SSDEF)' COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD DIMENSION READ_BTIM_SAVE(2),TEMP_BTIM(2) IF (FOLDER_NUMBER.GE.1000) GO TO 1000 C C We want to keep the last read date for comparison when selecting new C folders, so save it for later restoring. C READ_BTIM_SAVE(1) = READ_BTIM(1) READ_BTIM_SAVE(2) = READ_BTIM(2) CALL OPEN_BULLUSER_SHARED C C Newest date/time in user file only applies to general bulletins. C This was present before adding folder capability. C We set flags in user entry to show new folder added for folder bulletins. C However, the newest bulletin for each folder is not continually updated, C As it is only used when comparing to the last bulletin read time, and to C store this for each folder would be too expensive. C TEMP_BTIM(1) = NEWEST_BTIM(1) TEMP_BTIM(2) = NEWEST_BTIM(2) CALL READ_USER_FILE_HEADER(IER) NEWEST_BTIM(1) = TEMP_BTIM(1) NEWEST_BTIM(2) = TEMP_BTIM(2) IF (IER.NE.0) THEN CALL CLOSE_BULLUSER RETURN ELSE IF (FOLDER_NUMBER.EQ.0) THEN CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_BTIM) REWRITE (4,IOSTAT=IER) USER_HEADER END IF 1000 BROAD_MSG = .FALSE. IF (ADD_BULL.AND.FOLDER_NUMBER.GE.0) THEN ! Message added? IF (INCMD(:3).NE.'ADD') THEN BROAD_MSG = .TRUE. ELSE IF (.NOT.CLI$PRESENT('BROADCAST')) THEN BROAD_MSG = .TRUE. END IF END IF IF (BROAD_MSG) THEN IF (BTEST(FOLDER_FLAG,0)) THEN ! Folder protected? CALL CHKACL & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN CHECK_ACL = 0 ELSE CHECK_ACL = 1 END IF ELSE CHECK_ACL = 0 END IF CALL NOTIFY_USERS(CHECK_ACL) END IF IF (FOLDER_NUMBER.GE.1000) RETURN CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Reobtain present values as calling programs still uses them READ_BTIM(1) = READ_BTIM_SAVE(1) READ_BTIM(2) = READ_BTIM_SAVE(2) CALL CLOSE_BULLUSER RETURN END SUBROUTINE NOTIFY_USERS(CHECK_ACL) C C SUBROUTINE NOTIFY_USERS C C FUNCTION: Notify users with SET NOTIFY set of new message. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE '($BRKDEF)' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER OUTPUT*160,TERMINAL*8,FLAGS*4 CHARACTER*12 SENT_TEMP_USER,TEMP_USERNAME CHARACTER NEWS_ACCESS*132 CHARACTER FOLDER_NAME_SAVE*80 INTEGER SAVE_LAST_NEWS_READ(2,FOLDER_MAX) PARAMETER CR=CHAR(13),LF=CHAR(10),BELL=CHAR(7) DATA FIRST/.TRUE./, BROAD1_USER_QUEUE/0/, TEMP_USER_QUEUE/0/ OUTPUT = BELL//CR//LF//LF// & 'New bulletin added to folder '//FOLDER_NAME(: & TRIM(FOLDER_NAME)) & //'. From: '//FROM(:TRIM(FROM))//CR//LF// & 'Description: '//DESCRIP(:TRIM(DESCRIP)) IF (FIRST) THEN IER = SYS_TRNLNM('BULL_SYSTEM_FLAGS',FLAGS) IF (.NOT.IER) THEN IER = SYS_TRNLNM('MAIL$SYSTEM_FLAGS',FLAGS) END IF BFLAG = 0 READ (FLAGS(:1),'(I1)',IOSTAT=IER) FLAG IF (BTEST(FLAG,1).AND.IER.EQ.0) BFLAG = BRK$M_CLUSTER FIRST = .FALSE. FOLDER1_NAME = ' ' END IF CALL SYS$SETRWM(%VAL(1)) ! Don't wait if can't broadcast CALL INIT_QUEUE(BROAD1_USER_QUEUE,TEMP_USERNAME) BROAD_USER_QUEUE = BROAD1_USER_QUEUE IF (FOLDER_NAME_SAVE.EQ.FOLDER_NAME) THEN TEMP_USERNAME = ' ' DO WHILE (TEMP_USERNAME.NE.'*') CALL READ_QUEUE(%VAL(BROAD_USER_QUEUE),BROAD_USER_QUEUE, & TEMP_USERNAME) IF (TEMP_USERNAME.NE.'*') THEN CALL SYS$BRKTHRU(,OUTPUT(:TRIM(OUTPUT))//CR, & TEMP_USERNAME(:TRIM(TEMP_USERNAME)), & %VAL(BRK$C_USERNAME),,,%VAL(BFLAG),,%VAL(5),,) END IF END DO CALL SYS$SETRWM(%VAL(0)) RETURN END IF FOLDER_NAME_SAVE = FOLDER_NAME IF (REMOTE_SET.EQ.4) THEN CALL OPEN_BULLINF_SHARED CALL LIB$MOVC3(4*2*FOLDER_MAX,LAST_NEWS_READ, & SAVE_LAST_NEWS_READ) END IF CALL INIT_QUEUE(TEMP_USER_QUEUE,TEMP_USERNAME) CALL INIT_QUEUE(BROAD1_USER_QUEUE,TEMP_USERNAME) WRITE_TEMP_QUEUE = TEMP_USER_QUEUE BROAD_USER_QUEUE = BROAD1_USER_QUEUE DO WHILE (GETUSERS(TEMP_USERNAME,TERMINAL)) READ_TEMP_QUEUE = TEMP_USER_QUEUE SENT_TEMP_USER = ' ' DO WHILE (TEMP_USERNAME.NE.SENT_TEMP_USER.AND. & READ_TEMP_QUEUE.NE.WRITE_TEMP_QUEUE) CALL READ_QUEUE(%VAL(READ_TEMP_QUEUE),READ_TEMP_QUEUE, & SENT_TEMP_USER) END DO IF (TEMP_USERNAME.NE.SENT_TEMP_USER) THEN IF (REMOTE_SET.EQ.4) THEN CALL READ_NEWS_USERINFO(TEMP_USERNAME,IER) ELSE CALL READ_USER_FILE_KEYNAME(TEMP_USERNAME,IER) END IF CALL WRITE_QUEUE(%VAL(WRITE_TEMP_QUEUE),WRITE_TEMP_QUEUE, & TEMP_USERNAME) ELSE IER = 2 END IF IF (IER.EQ.0.AND.TEMP_USERNAME.NE.FROM.AND. & TEST_NOTIFY_FLAG(FOLDER_NUMBER)) THEN IF (CHECK_ACL) THEN IF (REMOTE_SET.EQ.4) THEN CALL CHECK_ACCESS & (NEWS_ACCESS(FOLDER_DESCRIP), & TEMP_USERNAME,IER,WRITE_ACCESS) ELSE CALL CHECK_ACCESS & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', & TEMP_USERNAME,IER,WRITE_ACCESS) END IF ELSE IER = 1 END IF IF (IER) THEN CALL SYS$BRKTHRU(,OUTPUT(:TRIM(OUTPUT))//CR, & TEMP_USERNAME(:TRIM(TEMP_USERNAME)), & %VAL(BRK$C_USERNAME),,,%VAL(BFLAG),,%VAL(5),,) CALL WRITE_QUEUE(%VAL(BROAD_USER_QUEUE), & BROAD_USER_QUEUE,TEMP_USERNAME) ELSE IF (REMOTE_SET.LT.3) THEN CALL CLR2(NOTIFY_FLAG,FOLDER_NUMBER) REWRITE (4,IOSTAT=IER) TEMP_USERNAME//USER_ENTRY(13:) END IF END IF END DO CALL SYS$SETRWM(%VAL(0)) IF (REMOTE_SET.EQ.4) THEN CALL CLOSE_BULLINF CALL LIB$MOVC3(4*2*FOLDER_MAX,SAVE_LAST_NEWS_READ, & LAST_NEWS_READ) END IF FOLDER1_NAME = FOLDER_NAME TEMP_USERNAME = '*' CALL WRITE_QUEUE(%VAL(BROAD_USER_QUEUE),BROAD_USER_QUEUE, & TEMP_USERNAME) RETURN END SUBROUTINE ADD_ENTRY C C SUBROUTINE ADD_ENTRY C C FUNCTION: Enters a new directory entry in the directory file. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER TODAY_TIME*32 COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD COMMON /LOCALPOST/ LOCAL_POST IF (REMOTE_SET) THEN LOCAL = .TRUE. IF (INCMD(:3).EQ.'ADD') LOCAL = CLI$PRESENT('LOCAL') IF (LOCAL) THEN WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,0,0,0,0 ELSE WRITE (REMOTE_UNIT,'(9A)',IOSTAT=IER) & 3,DESCRIP,EXDATE,EXTIME,SYSTEM,CLI$PRESENT('BROADCAST'), & CLI$PRESENT('BELL'),CLI$PRESENT('ALL'), & CLI$PRESENT('CLUSTER') END IF 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(,TODAY_TIME,F1_NEWEST_BTIM,) NEWEST_DATE = TODAY_TIME(:11) NEWEST_TIME = TODAY_TIME(13:23) NBULL = F1_NBULL CALL UPDATE_FOLDER ELSE WRITE (6,'(1X,A)') FOLDER1_COM(:I) END IF ELSE CALL DISCONNECT_REMOTE IF (INCMD(:4).EQ.'MOVE') CALL EXIT END IF CALL UPDATE_LOGIN(.TRUE.) RETURN END IF CALL READDIR(0,IER) IF (IER.NE.1) THEN NEWEST_EXDATE = '5-NOV-2056' NEWEST_EXTIME = '00:00:00.00' NEWEST_DATE = '5-NOV-1956' NEWEST_TIME = '00:00:00.00' NBULL = 0 IF (REMOTE_SET.NE.4) NBLOCK = 0 SHUTDOWN = 0 NEMPTY = 0 END IF CALL SYS$ASCTIM(,TODAY_TIME,,) NEWEST_DATE = TODAY_TIME(:11) NEWEST_TIME = TODAY_TIME(13:23) IF (.NOT.LOCAL_POST) THEN DATE = NEWEST_DATE TIME = NEWEST_TIME END IF IF (.NOT.BTEST(FOLDER_FLAG,13)) THEN DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) IF (DIFF.GT.0) THEN NEWEST_EXDATE = EXDATE NEWEST_EXTIME = EXTIME ELSE IF (DIFF.EQ.0) THEN DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME END IF END IF IF ((SYSTEM.AND.4).EQ.4) THEN SHUTDOWN = SHUTDOWN + 1 SHUTDOWN_DATE = DATE SHUTDOWN_TIME = TIME END IF IF (REMOTE_SET.EQ.4) THEN BLOCK = NBLOCK - LENGTH CALL WRITEDIR(NEWS_F_END+1,IER) ELSE BLOCK = NBLOCK + 1 CALL WRITEDIR(NBULL+1,IER) END IF IF (IER.NE.0) RETURN IF (REMOTE_SET.EQ.4) THEN NEWS_F_END = NEWS_F_END + 1 NBULL = NEWS_F_END F_NBULL = NEWS_F_END ELSE NBULL = NBULL + 1 NBLOCK = NBLOCK + LENGTH END IF CALL WRITEDIR(0,IER) IF (BTEST(FOLDER_FLAG,13)) THEN CALL READ_FIRST_EXPIRED(NDEL) DO WHILE (NDEL.GT.0.AND.NDEL.LE.NEWS_F_END.AND. & COMPARE_BTIM(EX_BTIM,NEWEST_EXBTIM).LT.0) IF (LENGTH.GT.0) CALL DUMP_MESSAGE() DELETE (UNIT=2) CALL READ_FIRST_EXPIRED(NDEL) END DO CALL OPEN_BULLNEWS_SHARED CALL READ_FOLDER_FILE_KEYNAME(NEWS_FOLDER,IER) FOLDER_FLAG = IBCLR(FOLDER_FLAG,13) CALL REWRITE_FOLDER_FILE(IER) CALL CLOSE_BULLNEWS END IF INQUIRE (UNIT=2,OPENED=IER) IF (IER) CALL CLOSE_BULLDIR CALL UPDATE_LOGIN(.TRUE.) IF (IER) CALL OPEN_BULLDIR RETURN END INTEGER FUNCTION COMPARE_BTIM(BTIM1,BTIM2) C C FUNCTION COMPARE_BTIM C C FUCTION: Compares times in binary format to see which is farther in future. C C INPUTS: C BTIM1 - First time in binary format C BTIM2 - Second time in binary format C OUTPUT: C Returns +1 if first time is farther in future C Returns -1 if second time is farther in future C Returns 0 if equal time C IMPLICIT INTEGER (A - Z) DIMENSION BTIM1(2),BTIM2(2),DIFF(2) CALL LIB$SUBX(BTIM1,BTIM2,DIFF) IF (DIFF(2).LT.0) THEN COMPARE_BTIM = -1 ELSE IF (DIFF(2).GE.0) THEN COMPARE_BTIM = +1 END IF RETURN END INTEGER FUNCTION MINUTE_DIFF(DATE2,DATE1) C C FUNCTION MINUTE_DIFF C C FUNCTION: Finds difference in minutes between 2 binary times. C C IMPLICIT INTEGER (A-Z) DIMENSION DATE1(2),DATE2(2) CALL LIB$DAY(DAYS1,DATE1,MSECS1) CALL LIB$DAY(DAYS2,DATE2,MSECS2) MINUTE_DIFF = (DAYS2-DAYS1)*24*60 + (MSECS2-MSECS1)/6000 RETURN END INTEGER FUNCTION COMPARE_DATE(DATE1,DATE2) C C FUNCTION COMPARE_DATE C C FUCTION: Compares dates to see which is farther in future. C C INPUTS: C DATE1 - First date (dd-mm-yy) C DATE2 - Second date (If is equal to ' ', then use present date) C OUTPUT: C Returns the difference in days between the two dates. C If the DATE1 is farther in the future, the output is positive, C else it is negative. C IMPLICIT INTEGER (A - Z) CHARACTER*(*) DATE1,DATE2 INTEGER USER_TIME(2) CALL SYS_BINTIM(DATE1,USER_TIME) CALL VERIFY_DATE(USER_TIME) C C LIB$DAY crashes if date invalid, which happened once due to an unknown C hardware or software error which created a date very far in the future. C CALL LIB$DAY(DAY1,USER_TIME) IF (DATE2.NE.' ') THEN CALL SYS_BINTIM(DATE2,USER_TIME) CALL VERIFY_DATE(USER_TIME) ELSE CALL SYS$GETTIM(USER_TIME) END IF CALL LIB$DAY(DAY2,USER_TIME) COMPARE_DATE = DAY1 - DAY2 RETURN END SUBROUTINE VERIFY_DATE(BTIM) IMPLICIT INTEGER (A-Z) DIMENSION BTIM(2),TEMP(2) CALL SYS_BINTIM(' 5-NOV-2011 00:00:00.00',TEMP) IER = COMPARE_BTIM(BTIM,TEMP) IF (IER.GT.0) THEN ! Date invalid BTIM(1) = TEMP(1) BTIM(2) = TEMP(2) END IF CALL SYS_BINTIM(' 5-NOV-1955 00:00:00.00',TEMP) IER = COMPARE_BTIM(BTIM,TEMP) IF (IER.LT.0) THEN ! Date invalid BTIM(1) = TEMP(1) BTIM(2) = TEMP(2) END IF RETURN END INTEGER FUNCTION COMPARE_TIME(TIME1,TIME2) C C FUNCTION COMPARE_TIME C C FUCTION: Compares times to see which is farther in future. C C INPUTS: C TIME1 - First time (hh:mm:ss.xx) C TIME2 - Second time C OUTPUT: C Outputs (TIME1-TIME2) in seconds. Thus, if TIME1 is further C in the future, outputs positive number, else negative. C IMPLICIT INTEGER (A-Z) CHARACTER*(*) TIME1,TIME2 CHARACTER*24 TODAY_TIME CHARACTER*12 TEMP2 IF (TIME2.EQ.' ') THEN CALL SYS$ASCTIM(,TODAY_TIME,,) TEMP2 = TODAY_TIME(13:23) ELSE TEMP2 = TIME2 END IF COMPARE_TIME = 3600*10*(ICHAR(TIME1(:1))-ICHAR(TEMP2(:1))) & +3600*(ICHAR(TIME1(2:2))-ICHAR(TEMP2(2:2))) & +60*10*(ICHAR(TIME1(4:4))-ICHAR(TEMP2(4:4))) & +60*(ICHAR(TIME1(5:5))-ICHAR(TEMP2(5:5))) & +10*(ICHAR(TIME1(7:7))-ICHAR(TEMP2(7:7))) & +(ICHAR(TIME1(8:8))-ICHAR(TEMP2(8:8))) IF (COMPARE_TIME.EQ.0) THEN COMPARE_TIME = 10*(ICHAR(TIME1(10:10))-ICHAR(TEMP2(10:10))) & +(ICHAR(TIME1(11:11))-ICHAR(TEMP2(11:11))) IF (COMPARE_TIME.GT.0) THEN COMPARE_TIME = 1 ELSE IF (COMPARE_TIME.LT.0) THEN COMPARE_TIME = -1 END IF END IF RETURN END C------------------------------------------------------------------------- C C The following are subroutines to create a linked-list queue for C temporary buffer storage of data that is read from files to be C outputted to the terminal. This is done so as to be able to close C the file as soon as possible. C C Each record in the queue has the following format. The first two C words are used for creating a character variable. The first word C contains the length of the character variable, the second contains C the address. The address is simply the address of the 3rd word of C the record. The last word in the record contains the address of the C next record. Every time a record is written, if that record has a C zero link, it adds a new record for the next write operation. C Therefore, there will always be an extra record in the queue. To C check for the end of the queue, the last word (link to next record) C is checked to see if it is zero. C C------------------------------------------------------------------------- SUBROUTINE INIT_QUEUE(HEADER,DATA) CHARACTER*(*) DATA INTEGER HEADER IF (HEADER.NE.0) RETURN ! Queue already initialized LENGTH = LEN(DATA) IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) CALL LIB$GET_VM(LENGTH+12,HEADER) CALL MAKE_CHAR(%VAL(HEADER),LEN(DATA),LENGTH) RETURN END SUBROUTINE WRITE_QUEUE(RECORD,NEXT,DATA) INTEGER RECORD(1) CHARACTER*(*) DATA LENGTH = RECORD(1) CALL COPY_CHAR(LENGTH,DATA,%VAL(%LOC(RECORD))) IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) NEXT = RECORD((LENGTH+12)/4) IF (NEXT.NE.0) RETURN CALL LIB$GET_VM(LENGTH+12,NEXT) CALL MAKE_CHAR(%VAL(NEXT),RECORD(1),LENGTH) RECORD((LENGTH+12)/4) = NEXT RETURN END SUBROUTINE READ_QUEUE(RECORD,NEXT,DATA) CHARACTER*(*) DATA INTEGER RECORD(1) LENGTH = RECORD(1) CALL COPY_CHAR(LENGTH,%VAL(%LOC(RECORD)),DATA) IF (MOD(LENGTH,4).NE.0) LENGTH = LENGTH + 4 - MOD(LENGTH,4) NEXT = RECORD((LENGTH+12)/4) RETURN END SUBROUTINE COPY_CHAR(LENGTH,INCHAR,OUTCHAR) CHARACTER*(*) INCHAR,OUTCHAR OUTCHAR = INCHAR(:LENGTH) RETURN END SUBROUTINE MAKE_CHAR(IARRAY,CHAR_LEN,REAL_LEN) IMPLICIT INTEGER (A-Z) DIMENSION IARRAY(1) IARRAY(1) = CHAR_LEN IARRAY(2) = %LOC(IARRAY(3)) IARRAY(REAL_LEN/4+3) = 0 RETURN END SUBROUTINE DISABLE_PRIVS C C SUBROUTINE DISABLE_PRIVS C C FUNCTION: Disable image high privileges. C IMPLICIT INTEGER (A-Z) INCLUDE '($PRVDEF)' COMMON /PRIVS/ SETPRV,PRV_DEPTH DIMENSION SETPRV(2) DATA PRV_DEPTH /0/ COMMON /REALPROC/ REALPROCPRIV(2) PRV_DEPTH = PRV_DEPTH + 1 IF (PRV_DEPTH.GT.1) RETURN CALL SYS$SETPRV(%VAL(0),,,SETPRV) ! Get privileges SETPRV(1) = SETPRV(1).AND..NOT.REALPROCPRIV(1) CALL SYS$SETPRV(%VAL(0),SETPRV,,) ! Disable installed privs RETURN END SUBROUTINE ENABLE_PRIVS C C SUBROUTINE ENABLE_PRIVS C C FUNCTION: Enable image high privileges. C IMPLICIT INTEGER (A-Z) COMMON /PRIVS/ SETPRV,PRV_DEPTH DIMENSION SETPRV(2) PRV_DEPTH = PRV_DEPTH - 1 IF (PRV_DEPTH.GT.1) RETURN CALL SYS$SETPRV(%VAL(1),SETPRV,,) ! Enable image privs RETURN END SUBROUTINE CHECK_PRIV_IO(ERROR) C C SUBROUTINE CHECK_PRIV_IO C C FUNCTION: Checks SYS$OUTPUT and SYS$ERROR to see if they need C privileges to output to. C IMPLICIT INTEGER (A-Z) COMMON /OUTPUT/ REASSIGNED LOGICAL REASSIGNED DATA REASSIGNED /.FALSE./ CALL DISABLE_PRIVS ! Disable SYSPRV IF (.NOT.REASSIGNED) THEN OPEN (UNIT=6,FILE='SYS$OUTPUT',IOSTAT=IER,STATUS='NEW') CLOSE (UNIT=6,STATUS='DELETE') END IF OPEN (UNIT=4,FILE='SYS$ERROR',IOSTAT=IER1,STATUS='NEW') IF (IER.NE.0.OR.IER1.NE.0) THEN IF (IER1.EQ.0) WRITE (4,100) IF (IER.EQ.0) WRITE (6,200) ERROR = 1 ELSE CLOSE (UNIT=4,STATUS='DELETE') ERROR = 0 END IF CALL ENABLE_PRIVS ! Enable SYSPRV 100 FORMAT(1X,'ERROR: SYS$OUTPUT cannot be opened.') 200 FORMAT(1X,'ERROR: SYS$ERROR cannot be opened.') RETURN END SUBROUTINE CHANGE_FLAG(CMD,FLAG) C C SUBROUTINE CHANGE_FLAG C C FUNCTION: Sets flags for specified folder. C C INPUTS: C CMD - LOGICAL*4 value. If TRUE, set flag. C If FALSE, clear flag. C FLAG - If 1, modify NEW_FLAG, if 2, modify SET_FLAG C If 3, modify BRIEF_FLAG, 4, modify NOTIFY_FLAG C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG) DIMENSION FLAGS(FLONG,4) EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) LOGICAL CMD DIMENSION READ_BTIM_SAVE(2) DATA CHANGE_FOLDER /.FALSE./ IF (CLI$PRESENT('FOLDER')) THEN IER = CLI$GET_VALUE('FOLDER',FOLDER1) IF (IER) THEN FOLDER_NUMBER_SAVE = FOLDER_NUMBER CALL OPEN_BULLFOLDER_SHARED CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) CALL CLOSE_BULLFOLDER IF (IER.NE.0) THEN WRITE (6,'('' ERROR: No such folder found.'')') RETURN ELSE IF (INDEX(FOLDER1,'.').GT.0.OR. & (FOLDER1(:1).GE.'a'.AND.FOLDER1(:1).LE.'z')) THEN WRITE (6,'('' ERROR: Command not valid for folder.'')') RETURN END IF END IF FOLDER_NUMBER = FOLDER1_NUMBER CHANGE_FOLDER = .TRUE. END IF C C Find user entry in BULLUSER.DAT to update information. C ENTRY CHANGE_FLAG_NOCMD(CMD,FLAG) CALL OPEN_BULLUSER_SHARED ! Open user file READ_BTIM_SAVE(1) = READ_BTIM(1) READ_BTIM_SAVE(2) = READ_BTIM(2) CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry IF (IER.GT.0) THEN ! No entry (how did this happen??) CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's today CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) ! Fake new entry CALL READ_USER_FILE_HEADER(IER) IF (CMD) THEN CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) ELSE CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) END IF NEW_FLAG(1) = 143 NEW_FLAG(2) = 0 CALL WRITE_USER_FILE_NEW(IER) ELSE IF (CMD) THEN CALL SET2(FLAGS(1,FLAG),FOLDER_NUMBER) ELSE CALL CLR2(FLAGS(1,FLAG),FOLDER_NUMBER) END IF NEW_FLAG(1) = 143 REWRITE (4,IOSTAT=IER) USER_ENTRY READ_BTIM(1) = READ_BTIM_SAVE(1) READ_BTIM(2) = READ_BTIM_SAVE(2) END IF IF (CMD.AND.FLAG.EQ.4.AND.FOLDER_BBOARD(:2).EQ.'::') THEN DO WHILE (REC_LOCK(IER)) READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER,NOTIFY_REMOTE END DO IF (IER.NE.0) THEN DO I=1,FLONG NOTIFY_REMOTE(I) = 0 END DO CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) WRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE ELSE CALL SET2(NOTIFY_REMOTE,FOLDER_NUMBER) REWRITE (4,IOSTAT=IER) '*NOTIFY ',NOTIFY_REMOTE END IF END IF CALL CLOSE_BULLUSER IF (CHANGE_FOLDER) THEN FOLDER_NUMBER = FOLDER_NUMBER_SAVE CHANGE_FOLDER = .FALSE. END IF RETURN END SUBROUTINE SET_VERSION C C SUBROUTINE SET_VERSION C C FUNCTION: Sets version number. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' DIMENSION FLAGS(FLONG,4) EQUIVALENCE (NEW_FLAG(1),FLAGS(1,1)) DIMENSION READ_BTIM_SAVE(2) C C Find user entry in BULLUSER.DAT to update information. C CALL OPEN_BULLUSER_SHARED ! Open user file READ_BTIM_SAVE(1) = READ_BTIM(1) READ_BTIM_SAVE(2) = READ_BTIM(2) CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry IF (IER.EQ.0) THEN NEW_FLAG(1) = 143 REWRITE (4,IOSTAT=IER) USER_ENTRY ! Write modified entry READ_BTIM(1) = READ_BTIM_SAVE(1) READ_BTIM(2) = READ_BTIM_SAVE(2) END IF CALL CLOSE_FILE (4) RETURN END SUBROUTINE CHECK_NEWUSER(USERNAME,DISMAIL,PASSCHANGE) C C SUBROUTINE CHECK_NEWUSER C C FUNCTION: Checks flags for a new: Whether DISMAIL is set, C and what the last password change was. C C INPUTS: C USERNAME - Username C OUTPUTS: C DISMAIL - Returns 1 if account has DISMAIL. C returns 0 if account has no DISMAIL. C PASSCHANGE - Date of last password change. C IMPLICIT INTEGER (A-Z) CHARACTER*(*) USERNAME INTEGER PASSCHANGE(2) INCLUDE '($UAIDEF)' CALL INIT_ITMLST CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) CALL ADD_2_ITMLST(8,UAI$_PWD_DATE,%LOC(PASSCHANGE)) CALL END_ITMLST(GETUAI_ITMLST) DISMAIL = 0 ! Set return false IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) ! Read Record IF (IER) THEN ! If username found IF (BTEST(FLAGS,UAI$V_NOMAIL)) THEN ! DISMAIL SET? DISMAIL = 1 ! Yep END IF END IF RETURN ! Return END ! End INTEGER FUNCTION SYS_TRNLNM(INPUT,OUTPUT) IMPLICIT INTEGER (A-Z) CHARACTER*(*) INPUT,OUTPUT PARAMETER LNM$_STRING = '2'X IF (INDEX(INPUT,']').GT.0) THEN SYS_TRNLNM = .FALSE. RETURN END IF CALL INIT_ITMLST ! Initialize item list IF (OUTPUT.NE.'DEFINED') CALL ADD_2_ITMLST_WITH_RET & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist EINPUT = INDEX(INPUT,':') - 1 IF (EINPUT.LE.0) EINPUT = TRIM(INPUT) SYS_TRNLNM = SYS$TRNLNM(,'LNM$FILE_DEV',INPUT(:EINPUT),, & %VAL(TRNLNM_ITMLST)) IF (SYS_TRNLNM.AND.OUTPUT.NE.'DEFINED') OUTPUT = OUTPUT(:OLEN) RETURN END INTEGER FUNCTION SYS_TRNLNM_SYSTEM_INDEX(INPUT,OUTPUT) IMPLICIT INTEGER (A-Z) CHARACTER*(*) INPUT,OUTPUT PARAMETER LNM$_STRING = '2'X PARAMETER LNM$_INDEX = '1'X PARAMETER LNM$_MAX_INDEX = '7'X DATA NINDEX /0/ IF (MAX_INDEX.LT.NINDEX) THEN NINDEX = 0 SYS_TRNLNM_SYSTEM_INDEX = 0 RETURN END IF EINPUT = INDEX(INPUT,':') - 1 IF (EINPUT.LE.0) EINPUT = TRIM(INPUT) IF (NINDEX.EQ.0) THEN CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(4,LNM$_MAX_INDEX,%LOC(MAX_INDEX)) CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist SYS_TRNLNM_SYSTEM_INDEX = SYS$TRNLNM(,'LNM$SYSTEM', & INPUT(:EINPUT),,%VAL(TRNLNM_ITMLST)) IF (.NOT.SYS_TRNLNM_SYSTEM_INDEX) RETURN END IF CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(4,LNM$_INDEX,%LOC(NINDEX)) CALL ADD_2_ITMLST_WITH_RET & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist SYS_TRNLNM_SYSTEM_INDEX = SYS$TRNLNM(,'LNM$SYSTEM', & INPUT(:EINPUT),,%VAL(TRNLNM_ITMLST)) IF (SYS_TRNLNM_SYSTEM_INDEX) OUTPUT = OUTPUT(:OLEN) NINDEX = NINDEX + 1 RETURN END INTEGER FUNCTION SYS_TRNLNM_SYSTEM(INPUT,OUTPUT) IMPLICIT INTEGER (A-Z) CHARACTER*(*) INPUT,OUTPUT PARAMETER LNM$_STRING = '2'X CALL INIT_ITMLST ! Initialize item list IF (OUTPUT.NE.'DEFINED') CALL ADD_2_ITMLST_WITH_RET & (LEN(OUTPUT),LNM$_STRING,%LOC(OUTPUT),%LOC(OLEN)) CALL END_ITMLST(TRNLNM_ITMLST) ! Get address of itemlist EINPUT = INDEX(INPUT,':') - 1 IF (EINPUT.LE.0) EINPUT = TRIM(INPUT) SYS_TRNLNM_SYSTEM = SYS$TRNLNM(,'LNM$SYSTEM', & INPUT(:EINPUT),,%VAL(TRNLNM_ITMLST)) IF (SYS_TRNLNM_SYSTEM.AND.OUTPUT.NE.'DEFINED') THEN OUTPUT = OUTPUT(:OLEN) END IF RETURN END INTEGER FUNCTION FILE_LOCK(IER,IER1) IMPLICIT INTEGER (A-Z) INCLUDE '($RMSDEF)' DATA INIT /.TRUE./ IF (INIT) THEN FILE_LOCK = 1 INIT = .FALSE. IER1 = 0 ELSE IF (IER.GT.0) THEN IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.RMS$_FLK) THEN FILE_LOCK = 1 CALL WAIT_SEC('01') ELSE FILE_LOCK = 0 INIT = .TRUE. END IF ELSE FILE_LOCK = 0 IER1 = 0 INIT = .TRUE. END IF END IF RETURN END SUBROUTINE ENABLE_CTRL IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' COMMON /CTRLY/ CTRLY COMMON /CTRL_LEVEL/ LEVEL COMMON /DEF_PROT/ ORIGINAL_DEF_PROT COMMON /KEYPAD/ KEYPAD_MODE QUIT = 1 ENTRY ENABLE_CTRL_EXIT QUIT = QUIT.AND.1 ! If called via entry, QUIT = 0 IF (QUIT.EQ.1) LEVEL = LEVEL - 1 IF (LEVEL.LT.0.AND.QUIT.EQ.1) THEN WRITE (6,'('' ERROR: Error in CTRL.'')') END IF IF (LEVEL.EQ.0.OR.QUIT.EQ.0) THEN CALL LIB$ENABLE_CTRL(CTRLY,) ! Enable CTRL-Y & -C END IF IF (QUIT.EQ.0) THEN IF (KEYPAD_MODE.EQ.0) THEN IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,) IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) END IF CALL CLOSE_TAG FOLDER_FLAG = 0 CALL SET_FOLDER_FILE(0) CALL UPDATE_USERINFO CALL PRINT_NOW CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,) CALL EXIT END IF QUIT = 0 ! Reinitialize RETURN END SUBROUTINE DISABLE_CTRL IMPLICIT INTEGER (A-Z) COMMON /CTRLY/ CTRLY COMMON /CTRL_LEVEL/ LEVEL DATA LEVEL /0/ IF (LEVEL.EQ.0) CALL LIB$DISABLE_CTRL(CTRLY,) LEVEL = LEVEL + 1 RETURN END SUBROUTINE CLEANUP_BULLFILE C C SUBROUTINE CLEANUP_BULLFILE C C FUNCTION: Searches for empty space in bulletin file and deletes it. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLFILES.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' CHARACTER BUFFER*128 CALL OPEN_BULLDIR_SHARED C C NOTE: Can't use READDIR for reading header since it'll spawn a C BULL/CLEANUP. (Fooey). C DO WHILE (REC_LOCK(IER)) READ (2,KEYID=0,KEY=HEADER_KEY,IOSTAT=IER) BULLDIR_HEADER END DO IF (NEMPTY.EQ.0) THEN ! No cleanup necessary CALL CLOSE_BULLDIR RETURN ELSE IF (NEMPTY.GT.0) THEN CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) ! Set protection to (SYSTEM:RWED,OWNER:RWED,,) OPEN (UNIT=11,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', 1 STATUS='UNKNOWN',IOSTAT=IER,DISPOSE='DELETE', 1 RECORDTYPE='FIXED',RECORDSIZE=32, 1 FORM='UNFORMATTED',INITIALSIZE=((NBLOCK-NEMPTY)*128)/512) ! Compressed version is number 1 IF (IER.NE.0) THEN WRITE (6,'('' Cannot open temporary file for'' & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) CALL ERRSNS(IDUMMY,IER) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF CALL CLOSE_BULLDIR CALL SYS$SETDFPROT(CUR_DEF_PROT,) RETURN END IF CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL', & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL') CALL OPEN_BULLFIL_SHARED ! Open bulletin file NBLOCK = 0 DO I=1,NBULL ! Copy bulletins to new file CALL READDIR(I,IER) ICOUNT = BLOCK DO J=1,LENGTH NBLOCK = NBLOCK + 1 DO WHILE (REC_LOCK(IER1)) READ(1'ICOUNT,IOSTAT=IER1) BUFFER END DO IF (IER1.NE.0) THEN ! This file is corrupt NBLOCK = NBLOCK - 1 NBULL = I - 1 GO TO 100 END IF WRITE(11) BUFFER ICOUNT = ICOUNT + 1 END DO END DO 100 CALL CLOSE_BULLFIL ELSE IF (NEMPTY.EQ.-1) THEN CALL CLOSE_BULLDIR CALL OPEN_BULLDIR ! Open with no sharing IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', & '*.BULLFIL') IER = 1 DO WHILE (IER) IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// & '.BULLFIL;-1') END DO IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', & '*.BULLDIR') CALL CLOSE_BULLDIR_DELETE IER = 1 DO WHILE (IER) IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// & '.BULLDIR;-1') END DO IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', & '*.*;1') RETURN END IF OPEN (UNIT=12,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED', & INITIALSIZE=(((NBULL+1)*DIR_RECORD_LENGTH)/512)+1 ) IF (IER.NE.0) THEN OPEN (UNIT=12,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.TMPDIR',STATUS='UNKNOWN',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') IF (IER.NE.0) THEN WRITE (6,'('' Cannot open temporary file for'' & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) CALL ERRSNS(IDUMMY,IER) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF CLOSE (UNIT=11) CALL CLOSE_BULLDIR CALL SYS$SETDFPROT(CUR_DEF_PROT,) RETURN END IF END IF CALL COPY_ACL(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR', & FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR') NEMPTY = 0 WRITE (12,IOSTAT=IER) BULLDIR_HEADER ! Write directory header NBLOCK = 0 ! Update directory entry pointers DO I=1,NBULL CALL READDIR(I,IER) BLOCK = NBLOCK + 1 CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE (12,IOSTAT=IER) BULLDIR_ENTRY IF (IER.NE.0) THEN WRITE (6,'('' Cannot write to temporary file for'' & ,'' compressing '',A)') FOLDER(:TRIM(FOLDER)) CALL ERRSNS(IDUMMY,IER) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF CLOSE (UNIT=12) CLOSE (UNIT=11) CALL CLOSE_BULLDIR CALL SYS$SETDFPROT(CUR_DEF_PROT,) RETURN END IF NBLOCK = NBLOCK + MAX(LENGTH,0) END DO CLOSE (UNIT=12,STATUS='KEEP') CLOSE (UNIT=11,STATUS='KEEP') CALL CLOSE_BULLDIR CALL OPEN_BULLDIR ! Open with no sharing NEMPTY = -1 ! Copying done, indicate that in case of crash WRITE (2,IOSTAT=IER) BULLDIR_HEADER ! Write new directory header IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPFIL', & '*.BULLFIL') IER = 1 DO WHILE (IER) IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// & '.BULLFIL;-1') END DO IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.TMPDIR', & '*.BULLDIR') CALL CLOSE_BULLDIR_DELETE IER = 1 DO WHILE (IER) IER = LIB$DELETE_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// & '.BULLDIR;-1') END DO IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULL*', & '*.*;1') CALL SYS$SETDFPROT(CUR_DEF_PROT,) RETURN END SUBROUTINE CLEANUP_DIRFILE(DELETE_ENTRY) C C SUBROUTINE CLEANUP_DIRFILE C C FUNCTION: Reorder directory file after deletions. C Is called either directly after a deletion, or is C called if it is detected that a deletion was not fully C completed due to the fact that the deleting process C was abnormally terminated. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLFILES.INC' INCLUDE 'BULLDIR.INC' CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE CHARACTER*12 DATE_SAVE,EXDATE_SAVE CHARACTER*12 TIME_SAVE,EXTIME_SAVE BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY DATE_SAVE = DATE TIME_SAVE = TIME EXDATE_SAVE = EXDATE EXTIME_SAVE = EXTIME NBULL = -NBULL ! Negative # Bulls signals deletion in progress MOVE_TO = 0 ! Moving directory entries starting here MOVE_FROM = 0 ! Moving directory entries from here I = DELETE_ENTRY ! Start search point for first deleted entries DO WHILE (MOVE_TO.EQ.0.AND.I.LE.NBULL) CALL READDIR(I,IER) IF (IER.NE.I+1) THEN ! Have we found a deleted entry? MOVE_TO = I ! If so, start moving entries to here J=I+1 ! Search for next entry in file DO WHILE (MOVE_FROM.EQ.0.AND.J.LE.NBULL) CALL READDIR(J,IER) IF (IER.EQ.J+1) MOVE_FROM = J J = J + 1 END DO IF (MOVE_FROM.EQ.0) THEN ! There are no more entries NBULL = I - 1 ! so just update number of bulletins CALL WRITEDIR(0,IER) RETURN END IF LENGTH = -LENGTH ! Indicate starting point by writing CALL WRITEDIR(I,IER) ! next entry into deleted entry FIRST_DELETE = I ! with negative length MOVE_FROM = MOVE_FROM + 1 ! Set up pointers to move rest of MOVE_TO = MOVE_TO + 1 ! the entries ELSE IF (LENGTH.LT.0) THEN ! If negative length found, deletion FIRST_DELETE = I ! was previously in progress J = I ! Try to find where entry came from CALL INIT_QUEUE(ENTRY_Q1,BULLDIR_ENTRY) ENTRY_Q = ENTRY_Q1 DO K=J,NBULL CALL READDIR(K,IER) IF (IER.EQ.K+1) THEN CALL WRITE_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) END IF END DO ENTRY_QLAST = ENTRY_Q ENTRY_Q2 = ENTRY_Q1 DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q2.NE.ENTRY_QLAST) CALL READ_QUEUE(%VAL(ENTRY_Q2),ENTRY_Q,BULLDIR_ENTRY) ENTRY_Q2 = ENTRY_Q BLOCK_SAVE = BLOCK MSG_NUM_SAVE = MSG_NUM DO WHILE (MOVE_FROM.EQ.0.AND.ENTRY_Q.NE.ENTRY_QLAST) ! Search for duplicate entries CALL READ_QUEUE(%VAL(ENTRY_Q),ENTRY_Q,BULLDIR_ENTRY) IF (BLOCK_SAVE.EQ.BLOCK) THEN MOVE_TO = MSG_NUM_SAVE + 1 MOVE_FROM = MSG_NUM + 1 END IF END DO ! If no duplicate entry found for this ! entry, see if one exists for any END DO ! of the other entries END IF I = I + 1 END DO IF (I.LE.NBULL) THEN ! Move reset of entries if necessary IF (MOVE_FROM.GT.0) THEN DO J=MOVE_FROM,NBULL CALL READDIR(J,IER) IF (IER.EQ.J+1) THEN ! Skip any other deleted entries CALL WRITEDIR(MOVE_TO,IER) MOVE_TO = MOVE_TO + 1 END IF END DO END IF DO J=MOVE_TO,NBULL ! Delete empty records at end of file CALL READDIR(J,IER) DELETE(UNIT=2,IOSTAT=IER) END DO NBULL = MOVE_TO - 1 ! Update # bulletin count END IF IF (FIRST_DELETE.GT.0) THEN CALL READDIR(FIRST_DELETE,IER) IF (IER.EQ.FIRST_DELETE+1.AND.LENGTH.LT.0) THEN LENGTH = -LENGTH ! Fix entry which has negative length CALL WRITEDIR(FIRST_DELETE,IER) END IF END IF CALL WRITEDIR(0,IER) BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE DATE = DATE_SAVE TIME = TIME_SAVE EXDATE = EXDATE_SAVE EXTIME = EXTIME_SAVE RETURN END SUBROUTINE SHOW_FLAGS C C SUBROUTINE SHOW_FLAGS C C FUNCTION: Show user flags. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT IF (FOLDER_NUMBER.LT.0) THEN WRITE (6,'('' ERROR: Cannot show flags for remote folder.'')') RETURN END IF C C Find user entry in BULLUSER.DAT to obtain flags. C IF (REMOTE_SET.LT.3) THEN CALL OPEN_BULLUSER_SHARED ! Open user file CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Read old entry ELSE IF (NEWS_FIND_SUBSCRIBE().GT.FOLDER_MAX-1) THEN WRITE (6,'('' ERROR: NEWS FOLDER is not subscribed.'')') RETURN END IF WRITE (6,'('' For the selected folder '',A)') & FOLDER_NAME(:TRIM(FOLDER_NAME)) IF (TEST_SET_FLAG(FOLDER_NUMBER).AND. & (.NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER))) THEN WRITE (6,'('' READNEW is set.'')') ELSE IF (TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. & TEST_SET_FLAG(FOLDER_NUMBER)) THEN WRITE (6,'('' BRIEF is set.'')') ELSE IF (TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. & .NOT.TEST_SET_FLAG(FOLDER_NUMBER)) THEN WRITE (6,'('' SHOWNEW is set.'')') END IF IF (REMOTE_SET.NE.3.AND.TEST_NOTIFY_FLAG(FOLDER_NUMBER)) THEN WRITE (6,'('' NOTIFY is set.'')') ELSE IF (.NOT.TEST_BRIEF_FLAG(FOLDER_NUMBER).AND. & .NOT.TEST_SET_FLAG(FOLDER_NUMBER)) THEN WRITE (6,'('' No flags are set.'')') END IF IF (REMOTE_SET.LT.3) CALL CLOSE_BULLUSER RETURN END SUBROUTINE SET2(FLAG,NUMBER) IMPLICIT INTEGER (A-Z) INTEGER FLAG(2) F_POINT = NUMBER/32 + 1 FLAG(F_POINT) = IBSET(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) RETURN END SUBROUTINE CLR2(FLAG,NUMBER) IMPLICIT INTEGER (A-Z) INTEGER FLAG(3) F_POINT = NUMBER/32 + 1 FLAG(F_POINT) = IBCLR(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) RETURN END LOGICAL FUNCTION TEST2(FLAG,NUMBER) IMPLICIT INTEGER (A-Z) INTEGER FLAG(3) F_POINT = NUMBER/32 + 1 TEST2 = BTEST(FLAG(F_POINT),NUMBER-32*(F_POINT-1)) RETURN END INTEGER FUNCTION GETUSERS(USERNAME,TERMINAL) C C FUNCTION GETUSERS C C FUNCTION: C To get names of all users that are logged in. C IMPLICIT INTEGER (A-Z) INCLUDE '($JPIDEF)' !*** MODULE $PSCANDEF *** PARAMETER PSCAN$_BEGIN = '00000000'X PARAMETER PSCAN$_ACCOUNT = '00000001'X PARAMETER PSCAN$_AUTHPRI = '00000002'X PARAMETER PSCAN$_CURPRIV = '00000003'X PARAMETER PSCAN$_GRP = '00000004'X PARAMETER PSCAN$_HW_MODEL = '00000005'X PARAMETER PSCAN$_HW_NAME = '00000006'X PARAMETER PSCAN$_JOBPRCCNT = '00000007'X PARAMETER PSCAN$_JOBTYPE = '00000008'X PARAMETER PSCAN$_MASTER_PID = '00000009'X PARAMETER PSCAN$_MEM = '0000000A'X PARAMETER PSCAN$_MODE = '0000000B'X PARAMETER PSCAN$_NODE_CSID = '0000000C'X PARAMETER PSCAN$_NODENAME = '0000000D'X PARAMETER PSCAN$_OWNER = '0000000E'X PARAMETER PSCAN$_PRCCNT = '0000000F'X PARAMETER PSCAN$_PRCNAM = '00000010'X PARAMETER PSCAN$_PRI = '00000011'X PARAMETER PSCAN$_PRIB = '00000012'X PARAMETER PSCAN$_STATE = '00000013'X PARAMETER PSCAN$_STS = '00000014'X PARAMETER PSCAN$_TERMINAL = '00000015'X PARAMETER PSCAN$_UIC = '00000016'X PARAMETER PSCAN$_USERNAME = '00000017'X PARAMETER PSCAN$_GETJPI_BUFFER_SIZE = '00000018'X PARAMETER PSCAN$_END = '00000019'X PARAMETER PSCAN$k_type = '00000081'X PARAMETER PSCAN$M_OR = '00000001'X PARAMETER PSCAN$M_BIT_ALL = '00000002'X PARAMETER PSCAN$M_BIT_ANY = '00000004'X PARAMETER PSCAN$M_GEQ = '00000008'X PARAMETER PSCAN$M_GTR = '00000010'X PARAMETER PSCAN$M_LEQ = '00000020'X PARAMETER PSCAN$M_LSS = '00000040'X PARAMETER PSCAN$M_PREFIX_MATCH = '00000080'X PARAMETER PSCAN$M_WILDCARD = '00000100'X PARAMETER PSCAN$M_CASE_BLIND = '00000200'X PARAMETER PSCAN$M_EQL = '00000400'X PARAMETER PSCAN$M_NEQ = '00000800'X STRUCTURE /item_specific_flags/ PARAMETER PSCAN$S_OR = 1 PARAMETER PSCAN$V_OR = 0 PARAMETER PSCAN$S_BIT_ALL = 1 PARAMETER PSCAN$V_BIT_ALL = 1 PARAMETER PSCAN$S_BIT_ANY = 1 PARAMETER PSCAN$V_BIT_ANY = 2 PARAMETER PSCAN$S_GEQ = 1 PARAMETER PSCAN$V_GEQ = 3 PARAMETER PSCAN$S_GTR = 1 PARAMETER PSCAN$V_GTR = 4 PARAMETER PSCAN$S_LEQ = 1 PARAMETER PSCAN$V_LEQ = 5 PARAMETER PSCAN$S_LSS = 1 PARAMETER PSCAN$V_LSS = 6 PARAMETER PSCAN$S_PREFIX_MATCH = 1 PARAMETER PSCAN$V_PREFIX_MATCH = 7 PARAMETER PSCAN$S_WILDCARD = 1 PARAMETER PSCAN$V_WILDCARD = 8 PARAMETER PSCAN$S_CASE_BLIND = 1 PARAMETER PSCAN$V_CASE_BLIND = 9 PARAMETER PSCAN$S_EQL = 1 PARAMETER PSCAN$V_EQL = 10 PARAMETER PSCAN$S_NEQ = 1 PARAMETER PSCAN$V_NEQ = 11 BYTE %FILL (2) END STRUCTURE CHARACTER USERNAME*(*),TERMINAL*(*) C C Replace all the lines in this subroutine with the following if C you are running V5.2 or older. C C DATA CONTEXT/-1/ C CALL INIT_ITMLST ! Initialize item list C ! Now add items to list C CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) C CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) C CALL ADD_2_ITMLST(4,JPI$_MODE,%LOC(UJPIMODE)) C CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist C IER = 1 C UJPIMODE = -1 C TERMINAL(1:1) = CHAR(0) C DO WHILE (IER.AND.(TERMINAL(1:1).EQ.CHAR(0)).AND.(UJPIMODE.NE. C * JPI$K_INTERACTIVE)) C ! Get next interactive process C IER = SYS$GETJPIW(,CONTEXT,,%VAL(GETJPI_ITMLST),,,,) C ! Get next process. C END DO C IF (.NOT.IER) CONTEXT = -1 C GETUSERS = IER DATA CONTEXT/0/ IF (CONTEXT.EQ.0) THEN CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST_WITH_RET(0,PSCAN$_NODE_CSID,0,PSCAN$M_NEQ) CALL ADD_2_ITMLST(0,PSCAN$_MODE,JPI$K_INTERACTIVE) CALL END_ITMLST(PSCAN_ITMLST) ! Get address of itemlist IER = SYS$PROCESS_SCAN(CONTEXT,%VAL(PSCAN_ITMLST)) END IF CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST(LEN(USERNAME),JPI$_USERNAME,%LOC(USERNAME)) CALL ADD_2_ITMLST(LEN(TERMINAL),JPI$_TERMINAL,%LOC(TERMINAL)) CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist IER = 1 TERMINAL(:1) = CHAR(0) DO WHILE (IER.AND.TERMINAL(:1).EQ.CHAR(0)) ! Get next interactive process IER = SYS$GETJPIW(,CONTEXT,,%VAL(GETJPI_ITMLST),,,,) ! Get next process. END DO IF (.NOT.IER) CONTEXT = 0 GETUSERS = IER RETURN END SUBROUTINE OPEN_USERINFO C C SUBROUTINE OPEN_USERINFO C C FUNCTION: Opens the file in SYS$LOGIN which contains user information. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLUSER.INC' COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) COMMON /USERINFO/ OLD_LAST_NEWS_READ(2,FOLDER_MAX) COMMON /USERINFO/ LAST(2,FOLDER_MAX) DATA USERINFO_READ /.FALSE./ INTEGER TODAY_BTIM(2) CALL OPEN_BULLINF_SHARED READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,LAST DO I=1,FOLDER_MAX DO J=1,2 LAST_READ_BTIM(J,I) = LAST(J,I) END DO END DO IF (IER.EQ.0) THEN ! Check to see if dates all in future CALL SYS_BINTIM('-',TODAY_BTIM) ! Get today's date DO I=1,FOLDER_MAX DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,I),TODAY_BTIM) IF (DIFF.GE.0) THEN ! Must have been in a time wrap LAST_READ_BTIM(1,I) = TODAY_BTIM(1) LAST_READ_BTIM(2,I) = TODAY_BTIM(2) END IF END DO END IF IF (IER.NE.0.AND.TEST_BULLCP().EQ.2 ! Is this BULLCP process? & .AND.CONFIRM_USER(USERNAME).NE.0) THEN ! Not real user? USERNAME = 'DECNET' READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,LAST DO I=1,FOLDER_MAX DO J=1,2 LAST_READ_BTIM(J,I) = LAST(J,I) END DO END DO END IF IF (IER.NE.0) THEN OPEN (UNIT=10,FILE='SYS$LOGIN:BULLETIN.INF',STATUS='OLD', & RECORDTYPE='FIXED',FORM='UNFORMATTED',IOSTAT=IER) INQUIRE(UNIT=10,RECORDSIZE=INF_SIZE) IF (IER.EQ.0) THEN READ (10) & ((LAST_READ_BTIM(1,I),LAST_READ_BTIM(2,I)),I=1,INF_SIZE/2) CLOSE (UNIT=10,STATUS='DELETE') ELSE CALL OPEN_BULLUSER_SHARED ! Get BULLUSER.DAT file CALL READ_USER_FILE_KEYNAME(USERNAME,IER) ! Find user's info IF (IER.NE.0.AND.TEST_BULLCP().EQ.2) THEN ! BULLCP process? CALL SYS_BINTIM('-',LOGIN_BTIM) ! Get today's date CALL SYS_BINTIM('5-NOV-1956 11:05:56',READ_BTIM) CALL READ_USER_FILE_HEADER(IER) NEW_FLAG(1) = 143 NEW_FLAG(2) = 0 CALL WRITE_USER_FILE_NEW(IER) END IF CALL CLOSE_BULLUSER IF (IER.EQ.0) THEN DO I=1,FOLDER_MAX LAST_READ_BTIM(1,I) = READ_BTIM(1) LAST_READ_BTIM(2,I) = READ_BTIM(2) END DO END IF END IF DO I=1,FOLDER_MAX DO J=1,2 LAST(J,I) = LAST_READ_BTIM(J,I) END DO END DO IF (IER.EQ.0) WRITE (9,IOSTAT=IER) USERNAME,LAST DO WHILE (REC_LOCK(IER)) READ (9,KEY='*DEFAULT',IOSTAT=IER) TEMP_USER,INF_REC END DO IF (IER.EQ.0) THEN LU = TRIM(USERNAME) USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) IF (LU.GT.1) THEN USERNAME(LU-1:LU-1) = & CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1))) ELSE USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2))) END IF WRITE (9,IOSTAT=IER) USERNAME,INF_REC USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) IF (LU.GT.1) THEN USERNAME(LU-1:LU-1) = & CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1))) ELSE USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2))) END IF END IF END IF LU = TRIM(USERNAME) USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) READ (9,KEY=USERNAME,IOSTAT=IER1) USERNAME,LAST_SYS_BTIM USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) IF (IER1.NE.0) THEN DO I=1,FOLDER_MAX LAST_SYS_BTIM(1,I) = 0 LAST_SYS_BTIM(2,I) = 0 END DO END IF CALL READ_NEWS_USERINFO(USERNAME,IER) CALL CLOSE_BULLINF CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_READ_BTIM(1,1) & ,OLD_LAST_READ_BTIM) CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_SYS_BTIM,OLD_LAST_SYS_BTIM) CALL LIB$MOVC3(FOLDER_MAX*2*4,LAST_NEWS_READ,OLD_LAST_NEWS_READ) USERINFO_READ = .TRUE. RETURN END SUBROUTINE READ_NEWS_USERINFO(NAME,IER) C C SUBROUTINE READ_NEWS_USERINFO C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLUSER.INC' CHARACTER*(*) NAME LU = TRIM(NAME) NAME(LU:LU) = CHAR(128.OR.ICHAR(NAME(LU:LU))) IF (LU.GT.1) THEN NAME(LU-1:LU-1) = CHAR(128.OR.ICHAR(NAME(LU-1:LU-1))) ELSE NAME(2:2) = CHAR(128.OR.ICHAR(NAME(2:2))) END IF READ (9,KEY=NAME,IOSTAT=IER) NAME,LAST_NEWS_READ NAME(LU:LU) = CHAR(127.AND.ICHAR(NAME(LU:LU))) IF (LU.GT.1) THEN NAME(LU-1:LU-1) = CHAR(127.AND.ICHAR(NAME(LU-1:LU-1))) ELSE NAME(2:2) = CHAR(127.AND.ICHAR(NAME(2:2))) END IF IF (IER.NE.0) THEN DO I=1,FOLDER_MAX LAST_NEWS_READ(1,I) = 0 LAST_NEWS_READ(2,I) = 0 END DO END IF RETURN END SUBROUTINE UPDATE_USERINFO C C SUBROUTINE UPDATE_USERINFO C C FUNCTION: Updates the latest message read times for each folder. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' COMMON /USERINFO/ USERINFO_READ,OLD_LAST_READ_BTIM(2,FOLDER_MAX) COMMON /USERINFO/ OLD_LAST_SYS_BTIM(2,FOLDER_MAX) COMMON /USERINFO/ OLD_LAST_NEWS_READ(2,FOLDER_MAX) COMMON /USERINFO/ LAST(2,FOLDER_MAX) EQUIVALENCE (OLD_LAST_NEWS_READ2(1,1),OLD_LAST_NEWS_READ(1,1)) INTEGER*2 OLD_LAST_NEWS_READ2(4,FOLDER_MAX) COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /LAST_FOLDER/ LAST_FOLDER_NUMBER IF (.NOT.USERINFO_READ) RETURN DIFF = .FALSE. IF (REMOTE_SET.EQ.0.OR.REMOTE_SET.EQ.1) THEN DIFF = (LAST_READ_BTIM(1,LAST_FOLDER_NUMBER+1).NE. & OLD_LAST_READ_BTIM(1,LAST_FOLDER_NUMBER+1)).OR. & (LAST_READ_BTIM(2,LAST_FOLDER_NUMBER+1).NE. & OLD_LAST_READ_BTIM(2,LAST_FOLDER_NUMBER+1)) END IF DIFF1 = .FALSE. IF (REMOTE_SET.EQ.0.OR.REMOTE_SET.EQ.1) THEN DIFF1 = (LAST_SYS_BTIM(1,LAST_FOLDER_NUMBER+1).NE. & OLD_LAST_SYS_BTIM(1,LAST_FOLDER_NUMBER+1)).OR. & (LAST_SYS_BTIM(2,LAST_FOLDER_NUMBER+1).NE. & OLD_LAST_SYS_BTIM(2,LAST_FOLDER_NUMBER+1)) END IF DIFF2 = .FALSE. GO TO 10 ENTRY UPDATE_USERINFO_NEWS_ALWAYS DIFF2 = .TRUE. 10 IF (.NOT.DIFF2) THEN DO I=1,FOLDER_MAX DIFF2 = (LAST_NEWS_READ(1,I).NE. & OLD_LAST_NEWS_READ(1,I)).OR. & (LAST_NEWS_READ(2,I).NE. & OLD_LAST_NEWS_READ(2,I)).OR.DIFF2 END DO END IF IF (.NOT.(DIFF.OR.DIFF1.OR.DIFF2)) RETURN CALL OPEN_BULLINF_SHARED IF (DIFF) THEN READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,LAST IF (IER.EQ.0) THEN DO I=1,FOLDER_MAX DO J=1,2 IF (LAST_FOLDER_NUMBER+1.EQ.I) & LAST(J,I) = LAST_READ_BTIM(J,I) LAST_READ_BTIM(J,I) = LAST(J,I) END DO END DO REWRITE (9,IOSTAT=IER) USERNAME,LAST END IF END IF IF (DIFF1) THEN LU = TRIM(USERNAME) USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,OLD_LAST_SYS_BTIM IF (IER.EQ.0) THEN DO I=1,FOLDER_MAX DO J=1,2 IF (LAST_FOLDER_NUMBER+1.EQ.I) & OLD_LAST_SYS_BTIM(J,I) = LAST_SYS_BTIM(J,I) LAST_SYS_BTIM(J,I) = OLD_LAST_SYS_BTIM(J,I) END DO END DO REWRITE (9,IOSTAT=IER) USERNAME,OLD_LAST_SYS_BTIM ELSE WRITE (9,IOSTAT=IER) USERNAME,LAST_SYS_BTIM END IF USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) END IF IF (DIFF2) THEN LU = TRIM(USERNAME) USERNAME(LU:LU) = CHAR(128.OR.ICHAR(USERNAME(LU:LU))) IF (LU.GT.1) THEN USERNAME(LU-1:LU-1) = CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1))) ELSE USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2))) END IF READ (9,KEY=USERNAME,IOSTAT=IER) USERNAME,OLD_LAST_NEWS_READ IF (IER.EQ.0) THEN DO I=1,FOLDER_MAX DO J=2,1,-1 IF (I.EQ.NEWS_FIND_SUBSCRIBE().OR. & OLD_LAST_NEWS_READ2(1,I).NE.LAST_NEWS_READ2(1,I)) & OLD_LAST_NEWS_READ(J,I) = LAST_NEWS_READ(J,I) LAST_NEWS_READ(J,I) = OLD_LAST_NEWS_READ(J,I) END DO END DO REWRITE (9,IOSTAT=IER) USERNAME,OLD_LAST_NEWS_READ ELSE WRITE (9,IOSTAT=IER) USERNAME,LAST_NEWS_READ END IF USERNAME(LU:LU) = CHAR(127.AND.ICHAR(USERNAME(LU:LU))) IF (LU.GT.1) THEN USERNAME(LU-1:LU-1) = CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1))) ELSE USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2))) END IF END IF CALL CLOSE_BULLINF RETURN END INTEGER FUNCTION SYS_BINTIM(TIME,BTIM) IMPLICIT INTEGER (A-Z) INTEGER BTIM(2) CHARACTER*(*) TIME CHARACTER*24 TIME1 TIME1 = TIME(FIRST_ALPHA(TIME):) DO I=TRIM(TIME1),2,-1 IF (TIME1(I-1:I).EQ.' ') TIME1(I-1:) = TIME1(I:) END DO IF (TIME1.EQ.'-') TIME1 = '-- :' IF (TRIM(TIME1).EQ.20) THEN SYS_BINTIM = SYS$BINTIM(TIME1//'.00',BTIM) ELSE SYS_BINTIM = SYS$BINTIM(TIME1(:MIN(TRIM(TIME1),23)),BTIM) END IF RETURN END SUBROUTINE NEW_MESSAGE_NOTIFICATION C C SUBROUTINE NEW_MESSAGE_NOTIFICATION C C FUNCTION: C C Update user's last read bulletin date. If new bulletins have been C added since the last time bulletins have been read, position bulletin C pointer so that next bulletin read is the first new bulletin, and C alert user. If READNEW set and no new bulletins, just exit. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' COMMON /READIT/ READIT COMMON /POINT/ BULL_POINT COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE CHARACTER*4 SEPARATE COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM COMMON /LOGIN_BTIM/ LOGIN_BTIM_SAVE(2) COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD IF (INCMD(:4).EQ.'SHOW') THEN CALL READ_IN_FOLDERS ! Read folder info ELSE IF (.NOT.LOGIN_SWITCH) THEN LOGIN_BTIM_SAVE(1) = LOGIN_BTIM(1) LOGIN_BTIM_SAVE(2) = LOGIN_BTIM(2) CALL UPDATE_READ(0) ! Update login time CALL SHOW_NEW_VERSION IF (CLI$PRESENT('SELECT_FOLDER')) THEN CALL SELECT_FOLDER(.TRUE.,IER) IF (IER) RETURN END IF CALL READ_IN_FOLDERS ! Read folder info ELSE LOGIN_SWITCH = .FALSE. ! So LOGIN_FOLDER entry doesn't END IF ! think it's called via LOGIN FOLDER_Q = SAVE_FOLDER_Q1 DO I = 1,SAVE_FOLDER_NUM CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) CALL CLR2(NEW_MSG,FOLDER_NUMBER) ! Clear new message flag IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN CALL SET2(NEW_MSG,FOLDER_NUMBER) ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. & (FOLDER_NUMBER.GT.0.AND. & TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND.READIT.EQ.1)) THEN IF (READIT.EQ.1.AND.SYSTEM_SWITCH.AND. & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM, & F_NEWEST_BTIM) ELSE DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_BTIM) IF (DIFF.LT.0.AND.READIT.EQ.1) THEN IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER).OR. & NEW_FLAG(2).NE.-1) THEN DIFF = COMPARE_BTIM(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) END IF IF (FOLDER_BBOARD(:2).EQ.'::'.AND.DIFF.GE.0) THEN IER = MINUTE_DIFF(LOGIN_BTIM_SAVE,F_NEWEST_BTIM) IF (IER.LE.15) DIFF = -1 END IF END IF END IF IF (F_NBULL.GT.0.AND.(DIFF.LT.0.OR.(READIT.EQ.1.AND. & BTEST(FOLDER_FLAG,7)))) THEN ! If new unread messages CALL SET2(NEW_MSG,FOLDER_NUMBER) ! Set new message flag END IF END IF END DO FOLDER_Q = SAVE_FOLDER_Q1 IF (READIT.EQ.0) THEN ! If not in READNEW mode CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) NEW_MESS = .FALSE. DO I = 1,SAVE_FOLDER_NUM-1 CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_BTIM) IF (DIFF.LT.0) THEN ! Are there unread messages? DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_NOSYS_BTIM) IF (DIFF.GT.0) THEN ! Unread non-system messages? DIFF = COMPARE_BTIM(LOGIN_BTIM,F_NEWEST_BTIM) ! No. Unread system messages? IF (DIFF.GT.0) THEN ! No, update last read time. LAST_READ_BTIM(1,FOLDER_NUMBER+1) = & F_NEWEST_BTIM(1) LAST_READ_BTIM(2,FOLDER_NUMBER+1) = & F_NEWEST_BTIM(2) END IF END IF IF (DIFF.LT.0) THEN WRITE (6,'('' There are new messages in '', & ''folder '',A)') FOLDER(:TRIM(FOLDER)) NEW_MESS = .TRUE. END IF END IF END IF END DO CALL NEWS_NEW_NOTIFICATION(NEWS_MESS) IF (INCMD(:4).EQ.'SHOW') THEN SAVE_FOLDER_Q1 = 0 RETURN END IF IF (NEW_MESS.OR.NEWS_MESS) THEN WRITE (6,'('' Type SELECT followed by foldername to'', & '' read above messages.'')') END IF SAVE_FOLDER_Q1 = 0 FOLDER_NUMBER = 0 CALL SELECT_FOLDER(.FALSE.,IER) DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_BTIM) IF (DIFF.LT.0.AND.F_NBULL.GT.0) THEN CALL FIND_NEWEST_BULL ! See if there are new messages IF (BULL_POINT.NE.-1) THEN WRITE(6,'('' Type READ to read new '',A,'' messages.'')') & FOLDER(:TRIM(FOLDER)) NEW_COUNT = F_NBULL - BULL_POINT DIG = 0 DO WHILE (NEW_COUNT.GT.0) NEW_COUNT = NEW_COUNT / 10 DIG = DIG + 1 END DO WRITE(6,'('' There are '',I,'' new messages.'')') & F_NBULL - BULL_POINT ! Alert user if new bulletins ELSE BULL_POINT = 0 LAST_READ_BTIM(1,FOLDER_NUMBER+1) = F_NEWEST_BTIM(1) LAST_READ_BTIM(2,FOLDER_NUMBER+1) = F_NEWEST_BTIM(2) END IF END IF ELSE ! READNEW mode. DO I = 1,SAVE_FOLDER_NUM CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) IF (TEST2(NEW_MSG,FOLDER_NUMBER)) THEN CALL SELECT_FOLDER(.FALSE.,IER) IF (IER) THEN IF (SYSTEM_SWITCH.AND. & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) THEN DIFF = COMPARE_BTIM(SYSTEM_LOGIN_BTIM,F_NEWEST_BTIM) ELSE DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & F_NEWEST_BTIM) IF (BTEST(FOLDER_FLAG,7)) DIFF = -1 IF (DIFF.LT.0.AND.TEST2(BRIEF_FLAG,FOLDER_NUMBER) & .AND.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN IF (DIFF.LT.0) THEN IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER IF (BULL_POINT.NE.-1.OR.NEW_FLAG(2).EQ.-1.OR. & .NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER)) & WRITE (6,'('' There are new messages in folder '' & ,A)') FOLDER(:TRIM(FOLDER)) ELSE WRITE (6,'('' There are new messages in folder '' & ,A)') FOLDER(:TRIM(FOLDER)) END IF DIFF = 0 END IF END IF IF (DIFF.LT.0) THEN IF (FOLDER_NUMBER.GT.0) CALL LOGIN_FOLDER IF (BULL_POINT.NE.-1) THEN IF (.NOT.TEST2(BRIEF_FLAG,FOLDER_NUMBER)) THEN IF (USERNAME(:3).EQ.'MRL'.OR.USERNAME(:7).EQ.'DNELSON') & TYPE *,LOGIN_BTIM,READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG SAVE_BULL_POINT = BULL_POINT REDO = .TRUE. DO WHILE (REDO) REDO = .FALSE. CALL READNEW(REDO) IF (REDO) CALL REDISPLAY_DIRECTORY BULL_POINT = SAVE_BULL_POINT END DO END IF END IF END IF END IF END IF END DO CALL NEWS_NEW_NOTIFICATION(NEWS_MESS) CALL EXIT END IF RETURN END SUBROUTINE READ_IN_FOLDERS IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' COMMON /SAVE_FOLDERS/ SAVE_FOLDER_Q1,SAVE_FOLDER_NUM DATA SAVE_FOLDER_Q1/0/ COMMON /READIT/ READIT COMMON /SYSTEM_FOLDERS/ SYSTEM_FLAG(FLONG),DUMMY(2) COMMON /SHUTDOWN/ NODE_NUMBER,NODE_AREA COMMON /SHUTDOWN/ SHUTDOWN_FLAG(FLONG) COMMON /COMMAND_SWITCHES/ LOGIN_SWITCH,SYSTEM_SWITCH COMMON /COMMAND_SWITCHES/ SYSTEM_LOGIN_BTIM(2) COMMON /COMMAND_SWITCHES/ REVERSE_SWITCH,SEPARATE CHARACTER*4 SEPARATE CALL INIT_QUEUE(SAVE_FOLDER_Q1,FOLDER_COM) FOLDER_Q = SAVE_FOLDER_Q1 CALL OPEN_BULLFOLDER_SHARED ! Go find folders SAVE_FOLDER_NUM = 0 FOLDER_NUMBER = 0 CALL READ_FOLDER_FILE_KEYNUM(FOLDER_NUMBER,IER) IF (LOGIN_SWITCH) FOLDER_NAME = FOLDER DO WHILE (IER.EQ.0) SAVE_FOLDER_NUM = SAVE_FOLDER_NUM + 1 IF (.NOT.TEST_BULLCP().AND.NODE_AREA.GT.0.AND.READIT.EQ.1 & .AND.TEST2(SHUTDOWN_FLAG,FOLDER_NUMBER)) THEN ELSE IF ((NEW_FLAG(1).LT.142.OR.NEW_FLAG(1).GT.143).AND. & TEST2(BRIEF_FLAG,FOLDER_NUMBER).AND. & .NOT.TEST2(SET_FLAG,FOLDER_NUMBER)) THEN CALL CHANGE_FLAG_NOCMD(0,3) CALL SET_VERSION ELSE IF (TEST2(SET_FLAG,FOLDER_NUMBER).OR. & TEST2(BRIEF_FLAG,FOLDER_NUMBER).OR. & (FOLDER_NUMBER.GT.0.AND.(BTEST(FOLDER_FLAG,2).OR. & TEST2(SYSTEM_FLAG,FOLDER_NUMBER)).AND.READIT.EQ.1)) THEN C C Unknown problem caused system folder flag in folder file to disappear C so this tests to see if the flag has disappeared and resets if needed. C IF (TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. & .NOT.BTEST(FOLDER_FLAG,2)) THEN FOLDER_FLAG = IBSET(FOLDER_FLAG,2) CALL REWRITE_FOLDER_FILE(IER) ELSE IF (.NOT.TEST2(SYSTEM_FLAG,FOLDER_NUMBER).AND. & BTEST(FOLDER_FLAG,2)) THEN INQUIRE (UNIT=4,OPENED=IER) CALL MODIFY_SYSTEM_LIST(IER) END IF END IF CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) CALL READ_FOLDER_FILE_KEYNUM_GT(FOLDER_NUMBER,IER) END DO CALL CLOSE_BULLFOLDER FOLDER_Q = SAVE_FOLDER_Q1 CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER_COM) RETURN END SUBROUTINE DISCONNECT_REMOTE IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' WRITE (6,'('' ERROR: Connection to remote folder disconnected.'')') FOLDER_NUMBER = 0 CALL SELECT_FOLDER(.FALSE.,IER) WRITE (6,'('' Resetting to '',A,'' folder.'')') & FOLDER(:TRIM(FOLDER)) RETURN END