C C BULLETIN11.FOR, Version 8/4/95 C Purpose: Bulletin board utility program. C Environment: VAX/VMS C Usage: Invoked by the BULLETIN command. C Programmer: Mark R. London C SUBROUTINE RESET IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT IF (REMOTE_SET.GE.3) THEN IF (NEWS_FIND_SUBSCRIBE().GT.FOLDER_MAX-1) THEN WRITE (6,'('' ERROR: NEWS group is not subscribed.'')') RETURN END IF END IF IF (CLI$PRESENT('CURRENT')) THEN MESSAGE_NUMBER = BULL_POINT ELSE IF (.NOT.CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P)) THEN MESSAGE_NUMBER = NBULL ELSE CALL GET_2_VALS(BULL_PARAMETER,LEN_P,MESSAGE_NUMBER,EBULL,IER) IF (IER.NE.0) THEN WRITE (6,'(A)') & ' ERROR: Specified message number has incorrect format.' RETURN END IF END IF CALL OPEN_BULLDIR_SHARED CALL READDIR(MESSAGE_NUMBER,IER) IF (IER.EQ.MESSAGE_NUMBER+1 ! Was message found? & .OR.REMOTE_SET.GE.3) THEN ! Ignore if news IF (REMOTE_SET.LT.3) THEN CALL COPY2(LAST_READ_BTIM(1,FOLDER_NUMBER+1),MSG_BTIM) ELSE I = NEWS_FIND_SUBSCRIBE() LAST_NEWS_READ(2,I) = MESSAGE_NUMBER LAST_NEWS_READ2(2,I) = MIN(8191,F_NBULL-MESSAGE_NUMBER) & .OR.(LAST_NEWS_READ2(2,I).AND.'C000'X) END IF ELSE WRITE(6,1030) MESSAGE_NUMBER END IF 100 IF (REMOTE_SET.GE.3) CALL READDIR(BULL_POINT,IER) CALL CLOSE_BULLDIR RETURN 1010 FORMAT(' ERROR: You have not read any message.') 1030 FORMAT(' ERROR: Message was not found: ',I) END SUBROUTINE TAG(ADD_OR_DEL,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./,BULL_NEWS_TAG /.FALSE./ COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD CHARACTER*12 TAG_KEY EXTERNAL CLI$_ABSENT,CLI$_NEGATED IF ((.NOT.BULL_TAG.AND.REMOTE_SET.LT.3) & .OR.(.NOT.BULL_NEWS_TAG.AND.REMOTE_SET.GE.3)) THEN CALL OPEN_NEW_TAG(IER) IF (.NOT.IER) RETURN END IF IF (REMOTE_SET.GE.3) THEN IF (NEWS_FIND_SUBSCRIBE().GT.FOLDER_MAX-1) THEN WRITE (6,'('' ERROR: NEWS group is not subscribed.'')') RETURN END IF END IF IF (ADD_OR_DEL.AND. & INCMD(:4).NE.'MARK'.AND.INCMD(:4).NE.'SEEN') THEN CALL ADD_TAG(IER,TAG_TYPE) RETURN END IF IF (INCMD(:4).EQ.'SEEN') THEN IF (CLI$PRESENT('READ').EQ.%LOC(CLI$_NEGATED)) THEN READ (13,KEYEQ=TAG_KEY(0,BULLDIR_HEADER,1), & IOSTAT=IER) IF (IER.EQ.0) DELETE (UNIT=13) BULL_TAG = IBCLR(BULL_TAG,1) RETURN END IF END IF IF (.NOT.CLI$PRESENT('NUMBER')) THEN IF (BULL_POINT.EQ.0) THEN ! No. Have we just read a bulletin? WRITE(6,1010) ! No, then error. RETURN ELSE IF (ADD_OR_DEL) THEN CALL ADD_TAG(IER,TAG_TYPE) ELSE CALL DEL_TAG(IER,TAG_TYPE) IF (IER.NE.0) THEN IF (TAG_TYPE.EQ.1) THEN WRITE (6,'('' ERROR: Message was not marked.'')') ELSE WRITE (6,'('' ERROR: Message was not seen.'')') END IF END IF END IF RETURN END IF CALL OPEN_BULLDIR_SHARED LAST = 0 DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) & .NE.%LOC(CLI$_ABSENT)) ! Get the specified messages CALL GET_2_VALS(BULL_PARAMETER,LEN_P,SBULL,EBULL,IER) IF (SBULL.LE.0.OR.IER.NE.0.OR.SBULL.GT.F_NBULL) THEN WRITE (6,'(A)') & ' ERROR: Specified message number has incorrect format.' GO TO 100 END IF DO MESSAGE_NUMBER = SBULL,MIN(EBULL,F_NBULL) CALL READDIR(MESSAGE_NUMBER,IER) IF (IER.NE.MESSAGE_NUMBER+1 ! Was message found? & .AND.REMOTE_SET.LT.3) THEN ! Ignore if news WRITE(6,1030) MESSAGE_NUMBER ! No GO TO 100 ELSE IF (ADD_OR_DEL) THEN CALL ADD_TAG(IER,TAG_TYPE) IF (TAG_TYPE.EQ.2.AND.MESSAGE_NUMBER.GT.LAST) THEN IF (REMOTE_SET.LT.3) THEN DIFF = COMPARE_BTIM(MSG_BTIM, & LAST_READ_BTIM(1,FOLDER_NUMBER+1)) IF (DIFF.GT.0) CALL COPY2(LAST_READ_BTIM & (1,FOLDER_NUMBER+1),MSG_BTIM) ELSE CALL NEWS_UPDATE_NEWEST_MESSAGE(MESSAGE_NUMBER) END IF LAST = MESSAGE_NUMBER END IF ELSE CALL DEL_TAG(IER,TAG_TYPE) END IF END DO END DO 100 IF (REMOTE_SET.GE.3) CALL READDIR(BULL_POINT,IER) CALL CLOSE_BULLDIR RETURN 1010 FORMAT(' ERROR: You have not read any message.') 1030 FORMAT(' ERROR: Message was not found: ',I) END SUBROUTINE ADD_TAG(IER,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE '($FORIOSDEF)' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG CHARACTER*12 TAG_KEY IF (REMOTE_SET.LT.3) THEN IF (TAG_TYPE.EQ.2.AND..NOT.BTEST(BULL_TAG,1)) THEN ! No SEEN tags WRITE (13,IOSTAT=IER) TAG_KEY(0,BULLDIR_HEADER,1) BULL_TAG = IBSET(BULL_TAG,1) END IF WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE) ELSE CALL ADD_NEWS_TAG(IER,TAG_TYPE) RETURN END IF IF (IER.NE.FOR$IOS_INCKEYCHG.AND.IER.NE.0) THEN WRITE (6,'('' ERROR: Unable to mark message.'')') CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF ELSE IER = 0 END IF RETURN END SUBROUTINE GET_FIRST_NEWS_TAG(IER,MESSAGE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) EQUIVALENCE (NEWS_MARK2(2),NEWS_NUMBER) EQUIVALENCE (NEWS_MARK2(1),NEWS_REC) EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /NEXT/ NEXT IER = 36 SUBNUM = NEWS_FIND_SUBSCRIBE() IF (SUBNUM.GT.FOLDER_MAX-1) RETURN DO J=1,2 IF (BTEST(READ_TAG,J)) I = J END DO IF (NEWS_TAG(3,I,SUBNUM).EQ.0) RETURN INQUIRE (UNIT=2,OPENED=CLOSE_IT) CLOSE_IT = .NOT.CLOSE_IT IF (CLOSE_IT) CALL OPEN_BULLDIR_SHARED OLD_NEXT = NEXT NEXT = .FALSE. J = F_START - 1 IER1 = J DO WHILE (J.LE.F_NBULL.AND.J+1.NE.IER1) J = J + 1 CALL READDIR(J,IER1) END DO IF (J+1.NE.IER1) THEN NEXT = OLD_NEXT IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END IF NEXT = .TRUE. DO MESSNUM = NEWS_TAG(1,I,SUBNUM),NEWS_TAG(2,I,SUBNUM) TEST = TEST_TAG(MESSNUM,%VAL(NEWS_TAG(3,I,SUBNUM)), & NEWS_TAG(1,I,SUBNUM)) IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST IF (TEST) THEN HEADER = .TRUE. CALL GET_NEXT_NEWS_TAG(IER,MESSNUM,HEADER,I,SUBNUM) IF (IER.EQ.0) MESSAGE = MESSNUM NEXT = OLD_NEXT IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END IF END DO NEXT = OLD_NEXT IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN ENTRY GET_THIS_NEWS_TAG(IER,MESSAGE,TAG_TYPE) IER = 36 SUBNUM = NEWS_FIND_SUBSCRIBE() IF (SUBNUM.GT.FOLDER_MAX-1) RETURN TAG_TYPE = 0 DO I=1,2 IF ((BTEST(READ_TAG,I).OR.BTEST(READ_TAG,3)) & .AND.(NEWS_TAG(3,I,SUBNUM).GT.0).AND. & (MSG_NUM.LE.NEWS_TAG(2,I,SUBNUM))) THEN TEST = TEST_TAG(MSG_NUM, & %VAL(NEWS_TAG(3,I,SUBNUM)),NEWS_TAG(1,I,SUBNUM)) IF (TEST) THEN IER = 0 TAG_TYPE = IBSET(TAG_TYPE,I) END IF END IF END DO IF (BTEST(READ_TAG,3)) THEN IF ((.NOT.BTEST(TAG_TYPE,2).OR..NOT.BTEST(READ_TAG,2)).AND. & (.NOT.BTEST(TAG_TYPE,1).OR..NOT.BTEST(READ_TAG,1))) THEN IER = 0 ELSE IER = 36 END IF END IF RETURN ENTRY GET_THIS_OR_NEXT_NEWS_TAG(NUM,IER,MESSAGE,TAG_TYPE) IER = 36 SUBNUM = NEWS_FIND_SUBSCRIBE() IF (SUBNUM.GT.FOLDER_MAX-1) RETURN HEADER = .FALSE. TAG_TYPE = 0 DO WHILE (IER.NE.0) I = 0 DO J=1,2 IF (NEWS_TAG(3,J,SUBNUM).GT.0.AND.BTEST(READ_TAG,J)) THEN IER = 36 MNUM = MAX(NEWS_TAG(1,J,SUBNUM),NUM) DO WHILE (IER.NE.0.AND.MNUM.LE.NEWS_TAG(2,J,SUBNUM)) TEST = TEST_TAG(MNUM,%VAL(NEWS_TAG(3,J,SUBNUM)), & NEWS_TAG(1,J,SUBNUM)) IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST IF (TEST) THEN IER = 0 ELSE MNUM = MNUM + 1 END IF END DO IF (IER.EQ.0) THEN IF (J.EQ.1) THEN MESSAGE = MNUM I = 1 ELSE IF (I.EQ.0.OR.MESSAGE.GT.MNUM) THEN MESSAGE = MNUM I = 2 END IF END IF END IF END DO IF (I.EQ.0) RETURN CALL GET_NEXT_NEWS_TAG(IER,MESSAGE,HEADER,I,SUBNUM) IF (IER.EQ.0) THEN IF (.NOT.BTEST(READ_TAG,3)) TAG_TYPE = IBSET(TAG_TYPE,I) IF (NEWS_TAG(3,3-I,SUBNUM).GT.0.AND. & MESSAGE.LE.NEWS_TAG(2,3-I,SUBNUM)) THEN IF (TEST_TAG(MESSAGE,%VAL(NEWS_TAG(3,3-I,SUBNUM)), & NEWS_TAG(1,3-I,SUBNUM))) THEN TAG_TYPE = IBSET(TAG_TYPE,3-I) END IF END IF RETURN ELSE IF (.NOT.BTEST(READ_TAG,3-I)) THEN RETURN END IF END DO RETURN END SUBROUTINE GET_NEXT_NEWS_TAG(IER,MESSNUM,HEADER,J,SUBNUM) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /NEXT/ NEXT INQUIRE (UNIT=2,OPENED=CLOSE_IT) CLOSE_IT = .NOT.CLOSE_IT IF (CLOSE_IT) CALL OPEN_BULLDIR_SHARED IER = 36 OLD_NEXT = NEXT DO WHILE (MESSNUM.LE.NEWS_TAG(2,J,SUBNUM).AND.IER.NE.0) I = MAX(NEWS_TAG(1,J,SUBNUM),MESSNUM) DO WHILE (IER.NE.0.AND.I.LE.NEWS_TAG(2,J,SUBNUM)) TEST = TEST_TAG(I,%VAL(NEWS_TAG(3,J,SUBNUM)), & NEWS_TAG(1,J,SUBNUM)) IF (BTEST(READ_TAG,3)) TEST = .NOT.TEST IF (TEST) THEN IER = 0 MESSNUM = I ELSE I = I + 1 END IF END DO IF (IER.EQ.0) THEN SAVE_MESSNUM = MESSNUM NEXT = .FALSE. CALL READDIR(MESSNUM,IER1) IF (IER1.NE.MESSNUM+1) THEN NEXT = .TRUE. CALL READDIR(MESSNUM,IER1) END IF IF (IER1.NE.MESSNUM+1) THEN IER = 36 IF (.NOT.BTEST(READ_TAG,3)) THEN CALL DEL_NEWS_TAG(J,MESSNUM,SUBNUM) ELSE NEXT = OLD_NEXT IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END IF IF (BTEST(READ_TAG,1).AND.BTEST(READ_TAG,2)) RETURN ELSE IF (MESSNUM.NE.SAVE_MESSNUM) THEN IER = 36 IF (.NOT.BTEST(READ_TAG,3)) THEN CALL DEL_NEWS_TAG(J,SAVE_MESSNUM,SUBNUM) END IF END IF ELSE MESSNUM = NEWS_TAG(2,J,SUBNUM) + 1 END IF END DO IF (IER.EQ.0.AND.HEADER) THEN MESSNUM = MESSNUM - 1 MSG_NUM = MESSNUM END IF NEXT = OLD_NEXT IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END SUBROUTINE ADD_NEWS_TAG(IER,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) IER = 0 SUBNUM = NEWS_FIND_SUBSCRIBE() IF (SUBNUM.GT.FOLDER_MAX-1) RETURN IF (NEWS_TAG(1,TAG_TYPE,SUBNUM).GT.F_START) THEN CALL LIB$FREE_VM((NEWS_TAG(2,TAG_TYPE,SUBNUM)- & NEWS_TAG(1,TAG_TYPE,SUBNUM))/8+1, & NEWS_TAG(3,TAG_TYPE,SUBNUM)) NEWS_TAG(2,TAG_TYPE,SUBNUM) = F_NBULL NEWS_TAG(3,TAG_TYPE,SUBNUM) = 0 END IF IF (NEWS_TAG(3,TAG_TYPE,SUBNUM).EQ.0.AND.F_NBULL.GE.F_START) THEN NEWS_TAG(1,TAG_TYPE,SUBNUM) = F_START NEWS_TAG(2,TAG_TYPE,SUBNUM) = F_NBULL CALL LIB$GET_VM((F_NBULL-F_START)/8+1, & NEWS_TAG(3,TAG_TYPE,SUBNUM)) CALL ZERO_VM((F_NBULL-F_START)/8+1, & %VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM))) ELSE IF (F_NBULL.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM)) THEN DO I=1,2 IF (NEWS_TAG(1,I,SUBNUM).GT.0) THEN CALL LIB$GET_VM((F_NBULL-NEWS_TAG(1,I,SUBNUM))/8+1,TEMP) CALL ZERO_VM((F_NBULL-NEWS_TAG(1,I,SUBNUM))/8+1, & %VAL(TEMP)) CALL LIB$MOVC3((NEWS_TAG(2,I,SUBNUM)- & NEWS_TAG(1,I,SUBNUM))/8+1, & %VAL(NEWS_TAG(3,I,SUBNUM)),%VAL(TEMP)) CALL LIB$FREE_VM((NEWS_TAG(2,I,SUBNUM)- & NEWS_TAG(1,I,SUBNUM))/8+1, & NEWS_TAG(3,I,SUBNUM)) NEWS_TAG(2,I,SUBNUM) = F_NBULL NEWS_TAG(3,I,SUBNUM) = TEMP END IF END DO END IF CALL SET_TAG(MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), & NEWS_TAG(1,TAG_TYPE,SUBNUM)) NEWS_TAG(4,TAG_TYPE,SUBNUM) = 1 RETURN END SUBROUTINE SET_TAG(NUM,TAGS,START) IMPLICIT INTEGER (A-Z) DIMENSION TAGS(1) I = (NUM-START)/32 J = NUM - START - I*32 TAGS(I+1) = IBSET(TAGS(I+1),J) RETURN END SUBROUTINE CLR_TAG(NUM,TAGS,START) IMPLICIT INTEGER (A-Z) DIMENSION TAGS(1) I = (NUM-START)/32 J = NUM - START - I*32 TAGS(I+1) = IBCLR(TAGS(I+1),J) RETURN END LOGICAL FUNCTION TEST_TAG(NUM,TAGS,START) IMPLICIT INTEGER (A-Z) DIMENSION TAGS(1) I = (NUM-START)/32 J = NUM - START - I*32 TEST_TAG = BTEST(TAGS(I+1),J) RETURN END SUBROUTINE DEL_TAG(IER,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER*12 TAG_KEY IER = 0 IF (REMOTE_SET.GE.3) THEN SUBNUM = NEWS_FIND_SUBSCRIBE() CALL DEL_NEWS_TAG(TAG_TYPE,MSG_NUM,SUBNUM) RETURN END IF DO WHILE (REC_LOCK(IER1)) READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE), & IOSTAT=IER1) END DO IF (IER1.NE.0) RETURN DELETE (UNIT=13,IOSTAT=IER1) RETURN END SUBROUTINE DEL_NEWS_TAG(TAG_TYPE,MSG_NUM,SUBNUM) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) IF (MSG_NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM).OR. & MSG_NUM.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM).OR..NOT.TEST_TAG & (MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)) & ,NEWS_TAG(1,TAG_TYPE,SUBNUM))) THEN RETURN ELSE NEWS_TAG(4,TAG_TYPE,SUBNUM) = 1 CALL CLR_TAG & (MSG_NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), & NEWS_TAG(1,TAG_TYPE,SUBNUM)) END IF RETURN END SUBROUTINE OPEN_OLD_TAG IMPLICIT INTEGER (A-Z) INCLUDE '($FORIOSDEF)' INCLUDE '($RMSDEF)' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) EQUIVALENCE (NEWS_MARK2(2),NEWS_NUMBER) EQUIVALENCE (NEWS_MARK2(1),NEWS_REC) EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) CHARACTER*12 BULL_MARK_DIR CHARACTER*12 TAG_KEY,INPUT_KEY IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) IF (IER) THEN BULL_MARK_DIR = 'BULL_MARK:' ELSE BULL_MARK_DIR = 'SYS$LOGIN:' END IF NTRIES = 0 DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=13,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) NTRIES = NTRIES + 1 END DO IF (IER.EQ.0) THEN BULL_TAG = IBSET(BULL_TAG,0) DO WHILE (REC_LOCK(IER1)) READ (13,KEY=TAG_KEY(0,BULLDIR_HEADER,1),IOSTAT=IER1) END DO IF (IER1.EQ.0) BULL_TAG = IBSET(BULL_TAG,1) DO WHILE (REC_LOCK(IER1)) READ (13,KEYGE=TAG_KEY('FFFF'X,BULLDIR_HEADER,1),IOSTAT=IER1) & INPUT_KEY END DO CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) IF (IER1.EQ.0.AND.FOLDER1_NUMBER.EQ.'FFFF'X) THEN MSG_KEY = INPUT_KEY(5:) CALL SYS$ASCTIM(,DATE,MSG_BTIM,) IF (COMPARE_DATE(DATE,' ').LT.-30) THEN DELETE (13) IER1 = 2 END IF END IF IF (IER1.NE.0.OR.FOLDER1_NUMBER.NE.'FFFF'X) THEN CLOSE (UNIT=13) IER1 = 1 DO WHILE (IER1) IER1 = LIB$DELETE_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME)) & //'.BULLMARK;-1') END DO CALL CONV$PASS_FILES( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARK', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARKTMP') CALL CONV$PASS_OPTIONS() CALL CONV$CONVERT() CALL LIB$RENAME_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARK', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARK;1') CALL LIB$RENAME_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARKTMP', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.BULLMARK') CALL LIB$DELETE_FILE(BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.BULLMARK;-1') DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=13,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) NTRIES = NTRIES + 1 END DO CALL SYS_BINTIM('-',MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE (13,IOSTAT=IER) TAG_KEY('FFFF'X,MSG_KEY,1) ELSE UNLOCK 13 END IF END IF NTRIES = 0 IF (IER.EQ.0.OR.IER.EQ.FOR$IOS_FILNOTFOU) THEN DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=23,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:4:INTEGER)) NTRIES = NTRIES + 1 END DO IF (IER.EQ.0) THEN IF (BULL_NEWS_TAG) RETURN BULL_NEWS_TAG = .TRUE. END IF DO WHILE (REC_LOCK(IER1)) READ (23,KEYEQ=0,IOSTAT=IER1) NEWS_MARK END DO IF (IER1.EQ.0) CALL SYS$ASCTIM(,DATE,NEWS_MARK(2),) IF (IER1.NE.0) THEN OPEN (UNIT=24,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & RECORDSIZE=128,DISPOSE='DELETE', & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:4:INTEGER)) DO WHILE (IER.EQ.0) DO WHILE (REC_LOCK(IER)) READ (23,IOSTAT=IER) NEWS_MARK END DO IF (IER.EQ.0) THEN I = NEWS_MARK2(1) NEWS_MARK2(1) = NEWS_MARK2(2) NEWS_MARK2(2) = I WRITE (24,IOSTAT=IER) NEWS_MARK END IF END DO NEWS_MARK(1) = 0 CALL SYS_BINTIM('-',NEWS_MARK(2)) WRITE (24,IOSTAT=IER) NEWS_MARK CLOSE (UNIT=24,DISPOSE='SAVE') CLOSE (UNIT=23,DISPOSE='DELETE') DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=23,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:4:INTEGER)) NTRIES = NTRIES + 1 END DO ELSE IF (COMPARE_DATE(DATE,' ').LT.-30) THEN CLOSE (UNIT=23) IER1 = 1 DO WHILE (IER1) IER1 = LIB$DELETE_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME)) & //'.NEWSMARK;-1') END DO CALL CONV$PASS_FILES( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARK', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARKTMP') CALL CONV$PASS_OPTIONS() CALL CONV$CONVERT() CALL LIB$RENAME_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARK', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARK;1') CALL LIB$RENAME_FILE( & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARKTMP', & BULL_MARK_DIR//USERNAME(:TRIM(USERNAME))//'.NEWSMARK') CALL LIB$DELETE_FILE(BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK;-1') DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=23,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:4:INTEGER)) NTRIES = NTRIES + 1 END DO DO WHILE (REC_LOCK(IER1)) READ (23,KEYEQ=0,IOSTAT=IER1) NEWS_MARK END DO CALL SYS_BINTIM('-',NEWS_MARK(2)) REWRITE (23,IOSTAT=IER) NEWS_MARK END IF END IF IF (IER.NE.0.AND.IER.NE.FOR$IOS_FILNOTFOU) THEN WRITE (6,'('' Unable to open mark file.'')') IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF RETURN END IF IF (BULL_NEWS_TAG) THEN OLD_NEWS_NUMBER = 0 NEWS_MARK(1) = 0 FOLDER_NUMBER_SAVE = NEWS_FOLDER_NUMBER CALL OPEN_BULLNEWS_SHARED DO WHILE (IER.EQ.0) DO WHILE (REC_LOCK(IER)) READ (23,KEYGT=NEWS_MARK(1),IOSTAT=IER) NEWS_MARK END DO IF (IER.EQ.0.AND.NEWS_NUMBER.NE.0) THEN IF (NEWS_NUMBER.NE.OLD_NEWS_NUMBER) THEN NEWS_FOLDER_NUMBER = NEWS_NUMBER SUBNUM = NEWS_FIND_SUBSCRIBE() IF (SUBNUM.GT.FOLDER_MAX-1) THEN DELETE (UNIT=23) ELSE OLD_NEWS_NUMBER = NEWS_NUMBER CALL READ_FOLDER_FILE_KEYNUM_TEMP & (NEWS_FOLDER_NUMBER,IER1) IF (IER1.NE.0) THEN CALL ERRSNS(IDUMMY,IER2) IF (IER2.NE.RMS$_RNF) SUBNUM = 0 ELSE DO I=1,2 NEWS_TAG(1,I,SUBNUM) = F1_START NEWS_TAG(2,I,SUBNUM) = F1_NBULL NEWS_TAG(4,I,SUBNUM) = 0 CALL LIB$GET_VM((F1_NBULL-F1_START)/8+1, & NEWS_TAG(3,I,SUBNUM)) CALL ZERO_VM((F1_NBULL-F1_START)/8+1, & %VAL(NEWS_TAG(3,I,SUBNUM))) END DO END IF END IF END IF IF (NEWS_NUMBER.EQ.OLD_NEWS_NUMBER) THEN IF (SUBNUM.EQ.0) THEN DELETE (UNIT=23) ELSE UNLOCK 23 IF (NEWS_REC.GT.0) THEN TAG_TYPE = 1 ELSE TAG_TYPE = 2 END IF IF (NEWS_FORMAT.EQ.0) THEN ! 16 bit numbers DO I=5,256 CALL SET_NEWS_TAG(INT(NEWS_MARK2(I)),SUBNUM, & TAG_TYPE) END DO ELSE DO I=3,128 CALL SET_NEWS_TAG(NEWS_MARK(I),SUBNUM,TAG_TYPE) END DO END IF END IF END IF END IF END DO NEWS_FOLDER_NUMBER = FOLDER_NUMBER_SAVE CALL CLOSE_BULLNEWS END IF RETURN END SUBROUTINE SET_NEWS_TAG(NUM,SUBNUM,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) IF (NUM.GT.0) THEN LAST_NUM = NUM IF (NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM).OR. & NUM.GT.NEWS_TAG(2,TAG_TYPE,SUBNUM)) RETURN CALL SET_TAG(NUM,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), & NEWS_TAG(1,TAG_TYPE,SUBNUM)) ELSE IF (NUM.LT.0) THEN IF (-NUM.LT.NEWS_TAG(1,TAG_TYPE,SUBNUM)) RETURN DO J=MAX(NEWS_TAG(1,TAG_TYPE,SUBNUM),LAST_NUM+1), & MIN(NEWS_TAG(2,TAG_TYPE,SUBNUM),-NUM) CALL SET_TAG(J,%VAL(NEWS_TAG(3,TAG_TYPE,SUBNUM)), & NEWS_TAG(1,TAG_TYPE,SUBNUM)) END DO END IF RETURN END SUBROUTINE OPEN_NEW_TAG(IER) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) CHARACTER*12 BULL_MARK_DIR DIMENSION BTIM(2) CHARACTER KEY*8 IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) IF (IER) THEN BULL_MARK_DIR = 'BULL_MARK:' ELSE BULL_MARK_DIR = 'SYS$LOGIN:' END IF IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) IF (.NOT.IER1) THEN IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) CALL DISABLE_PRIVS IER1 = .FALSE. END IF IF (REMOTE_SET.LT.3) THEN MARKUNIT = 13 OPEN (UNIT=MARKUNIT,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & RECORDSIZE=3, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) IF (IER.EQ.0) THEN CALL SYS_BINTIM('-',BTIM) CALL GET_MSGKEY(BTIM,KEY) WRITE (13) TAG_KEY('FFFF'X,KEY,0) END IF ELSE MARKUNIT = 23 OPEN (UNIT=MARKUNIT,FILE=BULL_MARK_DIR// & USERNAME(:TRIM(USERNAME))//'.NEWSMARK',STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & RECORDSIZE=128, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:4:INTEGER)) IF (IER.EQ.0) THEN NEWS_MARK(1) = 0 CALL SYS_BINTIM('-',NEWS_MARK(2)) WRITE (23,IOSTAT=IER) NEWS_MARK END IF END IF IF (.NOT.IER1) CALL ENABLE_PRIVS IF (IER.NE.0) THEN WRITE (6,'('' Cannot create mark file.'')') CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER IER = 0 ELSE CALL SYS_GETMSG(IER1) IER = IER1 END IF ELSE IF (.NOT.IER1) THEN INQUIRE (UNIT=MARKUNIT,NAME=BULL_PARAMETER) WRITE (6,'('' Created MARK file: '',A)') & BULL_PARAMETER(:TRIM(BULL_PARAMETER)) END IF IF (MARKUNIT.EQ.13) BULL_TAG = 1 IF (MARKUNIT.EQ.23) BULL_NEWS_TAG = .TRUE. IER = 1 END IF RETURN END CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY,TAG_TYPE) IMPLICIT INTEGER (A-Z) CHARACTER*(*) MSG_KEY IF (TAG_TYPE.EQ.1) THEN CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) ELSE CALL LIB$MOVC3(4,-(1+FOLDER_NUMBER),%REF(TAG_KEY)) END IF CALL GET_MSGKEY(%REF(MSG_KEY),TAG_KEY(5:)) RETURN END SUBROUTINE GET_FIRST_TAG(FOLDER_NUMBER,IER,MESSAGE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER*12 TAG_KEY,INPUT_KEY CHARACTER*8 NEXT_MSG_KEY IF ((.NOT.BULL_TAG.AND.REMOTE_SET.LT.3) & .OR.(.NOT.BULL_NEWS_TAG.AND.REMOTE_SET.GE.3)) THEN CALL OPEN_NEW_TAG(IER) IF (.NOT.IER) RETURN END IF IF (REMOTE_SET.GE.3) THEN CALL GET_FIRST_NEWS_TAG(IER,MESSAGE) RETURN END IF IF (BTEST(READ_TAG,3)) THEN MSG_NUM = 0 CALL GET_NEXT_UNTAG(FOLDER_NUMBER,IER,MESSAGE,DUMMY) IF (IER.EQ.0) THEN MESSAGE = MESSAGE - 1 MSG_NUM = MESSAGE MSG_KEY = BULLDIR_HEADER END IF RETURN END IF MSG_KEY = BULLDIR_HEADER HEADER = .TRUE. DO J=1,2 IF (BTEST(READ_TAG,J)) I = J END DO CALL CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,I) RETURN ENTRY GET_THIS_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) IF (REMOTE_SET.GE.3) THEN CALL GET_THIS_NEWS_TAG(IER,MESSAGE,TAG_TYPE) RETURN END IF TAG_TYPE = 0 DO I=1,2 IF (BTEST(READ_TAG,I).OR.BTEST(READ_TAG,3)) THEN DO WHILE (REC_LOCK(IER)) READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY,I), & IOSTAT=IER) INPUT_KEY END DO IF (IER.EQ.0) TAG_TYPE = IBSET(TAG_TYPE,I) END IF END DO IF ((TAG_TYPE.NE.0.AND..NOT.BTEST(READ_TAG,3)).OR. & (BTEST(READ_TAG,3).AND. & (.NOT.BTEST(TAG_TYPE,2).OR..NOT.BTEST(READ_TAG,2)).AND. & (.NOT.BTEST(TAG_TYPE,1).OR..NOT.BTEST(READ_TAG,1)))) THEN IF (IER.EQ.0) UNLOCK 13 IER = 0 MESSAGE = MSG_NUM ELSE IER = 36 END IF RETURN ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) MSG_NUM = MSG_NUM - 1 CALL DECREMENT_MSG_KEY ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) IF (REMOTE_SET.GE.3) THEN MSG_NUM = ABS(MSG_NUM) + 1 CALL GET_THIS_OR_NEXT_NEWS_TAG(MSG_NUM,IER,MESSAGE,TAG_TYPE) RETURN END IF IER = 36 HEADER = .FALSE. TAG_TYPE = 0 IF (BTEST(READ_TAG,3)) THEN CALL GET_NEXT_UNTAG(FOLDER_NUMBER,IER,MESSAGE,TAG_TYPE) RETURN END IF DO WHILE (IER.NE.0) I = 0 DO J=1,2 IF (BTEST(READ_TAG,J)) THEN DO WHILE (REC_LOCK(IER)) READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY,J), & IOSTAT=IER) INPUT_KEY END DO IF (IER.EQ.0) THEN CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) IF ((J.EQ.1.AND.FOLDER1_NUMBER.NE.FOLDER_NUMBER).OR. & (J.EQ.2.AND.FOLDER1_NUMBER.NE.-(1+FOLDER_NUMBER))) & IER = 36 END IF IF (IER.EQ.0) THEN IF (J.EQ.1) THEN NEXT_MSG_KEY = INPUT_KEY(5:) I = 1 ELSE IF (I.EQ.0.OR.COMPARE_MSG_KEY(NEXT_MSG_KEY, & INPUT_KEY(5:)).GT.0) THEN I = 2 END IF END IF END IF END DO IF (I.EQ.0) RETURN NEXT_MSG_KEY = MSG_KEY CALL CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,I) IF (IER.EQ.0) THEN TAG_TYPE = IBSET(TAG_TYPE,I) DO WHILE (REC_LOCK(IER)) READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY,3-I), & IOSTAT=IER) INPUT_KEY END DO IF (IER.EQ.0) TAG_TYPE = IBSET(TAG_TYPE,3-I) IER = 0 RETURN ELSE IF (.NOT.BTEST(READ_TAG,3-I)) THEN MSG_KEY = NEXT_MSG_KEY RETURN ELSE MSG_KEY = NEXT_MSG_KEY END IF END DO RETURN END SUBROUTINE GET_NEXT_UNTAG(FN,IER,MESSAGE,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG INQUIRE (UNIT=2,OPENED=CLOSE_IT) CLOSE_IT = .NOT.CLOSE_IT IF (CLOSE_IT) CALL OPEN_BULLDIR_SHARED DO MESSAGE = MSG_NUM+1,F_NBULL CALL READDIR(MESSAGE,IER) IF (IER.EQ.MESSAGE+1) THEN CALL GET_THIS_TAG(FN,IER,DUMMY,TAG_TYPE) IF (IER.EQ.0) THEN IER = 0 IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END IF END IF END DO IER = 36 IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END INTEGER FUNCTION COMPARE_MSG_KEY(MSG_KEY1,MSG_KEY2) IMPLICIT INTEGER (A-Z) CHARACTER*8 MSG_KEY1,MSG_KEY2 DIMENSION BTIM1(2),BTIM2(2) CALL GET_MSGBTIM(MSG_KEY1,BTIM1) CALL GET_MSGBTIM(MSG_KEY2,BTIM2) COMPARE_MSG_KEY = COMPARE_BTIM(BTIM1,BTIM2) RETURN END SUBROUTINE CONFIRM_TAG(IER,FOLDER_NUMBER,MESSAGE,HEADER,J) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG CHARACTER*12 TAG_KEY,INPUT_KEY DO WHILE (REC_LOCK(IER)) READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY,J),IOSTAT=IER) & INPUT_KEY END DO CLOSE_IT = .FALSE. DO WHILE (FOLDER_NUMBER.GT.0) IF (IER.EQ.0) THEN CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),MSG_KEY) CALL LIB$MOVC3(4,%REF(INPUT_KEY),FOLDER1_NUMBER) END IF IF (IER.EQ.0) THEN IF ((J.EQ.1.AND.FOLDER1_NUMBER.NE.FOLDER_NUMBER).OR. & (J.EQ.2.AND.FOLDER1_NUMBER.NE.-(1+FOLDER_NUMBER))) & IER = 36 END IF IF (IER.NE.0) THEN IER = 1 UNLOCK 13 IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN ELSE CALL DECREMENT_MSG_KEY CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) INQUIRE (UNIT=2,OPENED=IER) IF (.NOT.IER) THEN CALL OPEN_BULLDIR_SHARED CLOSE_IT = .TRUE. END IF CALL READDIR_KEYGE(IER) CALL GET_MSGKEY(%REF(INPUT_KEY(5:)),INPUT_KEY(5:)) IF (IER.NE.0.AND.MSG_KEY.EQ.INPUT_KEY(5:)) THEN UNLOCK 13 MESSAGE = MSG_NUM IF (HEADER) THEN MESSAGE = MESSAGE - 1 MSG_NUM = MESSAGE MSG_KEY = BULLDIR_HEADER END IF IER = 0 IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN ELSE DELETE (UNIT=13) IF (BTEST(READ_TAG,1).AND.BTEST(READ_TAG,2)) THEN IER = 36 IF (CLOSE_IT) CALL CLOSE_BULLDIR RETURN END IF DO WHILE (REC_LOCK(IER)) READ (13,IOSTAT=IER) INPUT_KEY END DO END IF END IF END DO END SUBROUTINE CLOSE_TAG IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) EQUIVALENCE (NEWS_MARK2(2),NEWS_NUMBER) EQUIVALENCE (NEWS_MARK2(1),NEWS_REC) EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) TAG_OPENED = .FALSE. IF (BULL_NEWS_TAG) THEN DO I=1,FOLDER_MAX-1 DO M=1,2 IF (NEWS_TAG(3,M,I).NE.0.AND.NEWS_TAG(4,M,I).EQ.1) THEN IF (.NOT.TAG_OPENED) THEN CALL OPEN_OLD_TAG TAG_OPENED = .TRUE. END IF IF (M.EQ.1) THEN NEWS_REC = 1 ELSE NEWS_REC = -32767 END IF NEWS_FORMAT = 0 IF (NEWS_TAG(2,M,I).GT.32767) NEWS_FORMAT = 1 LIMIT = 256/(NEWS_FORMAT+1) NEWS_NUMBER = LAST_NEWS_READ2(1,I) K = 5-NEWS_FORMAT*2 SET_LIST = .FALSE. DO J=NEWS_TAG(1,M,I),NEWS_TAG(2,M,I) IF (TEST_TAG(J,%VAL(NEWS_TAG(3,M,I)), & NEWS_TAG(1,M,I))) THEN IF (.NOT.SET_LIST) THEN CALL SET_NEWS_MARK(K,J) LAST_SET = J K = K + 1 SET_LIST = .TRUE. END IF ELSE IF (SET_LIST) THEN IF (LAST_SET.NE.J-1) THEN CALL SET_NEWS_MARK(K,-(J-1)) K = K + 1 END IF SET_LIST = .FALSE. END IF IF (J.EQ.NEWS_TAG(2,M,I)) THEN IF (SET_LIST.AND.LAST_SET.NE.J) THEN CALL SET_NEWS_MARK(K,-J) K = K + 1 END IF DO L=K,LIMIT CALL SET_NEWS_MARK(L,0) END DO K = LIMIT + 1 END IF IF (K.GT.LIMIT) THEN DO WHILE (REC_LOCK(IER)) READ (23,KEYEQ=NEWS_MARK(1),IOSTAT=IER) END DO IF (IER.NE.0) THEN WRITE (23,IOSTAT=IER) NEWS_MARK ELSE REWRITE (23,IOSTAT=IER) NEWS_MARK END IF K = 5-NEWS_FORMAT*2 NEWS_REC = NEWS_REC + 1 IF (J.EQ.NEWS_TAG(2,M,I)) THEN DO WHILE (REC_LOCK(IER)) READ (23,KEYEQ=NEWS_MARK(1),IOSTAT=IER) IF (IER.EQ.0) THEN DELETE (UNIT=23) NEWS_REC = NEWS_REC + 1 L = REC_LOCK(IER) END IF END DO END IF END IF END DO END IF END DO END DO CLOSE (UNIT=23) END IF RETURN END SUBROUTINE SET_NEWS_MARK(I,J) IMPLICIT INTEGER (A-Z) COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) EQUIVALENCE (NEWS_MARK2(2),NEWS_NUMBER) EQUIVALENCE (NEWS_MARK2(1),NEWS_REC) EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) IF (NEWS_FORMAT.EQ.0) THEN NEWS_MARK2(I) = J ELSE NEWS_MARK(I) = J END IF RETURN END SUBROUTINE ZERO_VM(NUM,NEWS_TAG) IMPLICIT INTEGER (A-Z) LOGICAL*1 NEWS_TAG(1) DO I=1,NUM NEWS_TAG(I) = 0 END DO RETURN END SUBROUTINE FREE_TAGS(ISUB) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' COMMON /NEWS_TAGS/ NEWS_TAG(4,2,FOLDER_MAX-1) COMMON /NEWS_MARK/ NEWS_MARK DIMENSION NEWS_MARK(128) INTEGER*2 NEWS_MARK2(256),NEWS_NUMBER,NEWS_REC EQUIVALENCE (NEWS_MARK(1),NEWS_MARK2(1)) EQUIVALENCE (NEWS_MARK2(2),NEWS_NUMBER) EQUIVALENCE (NEWS_MARK2(1),NEWS_REC) EQUIVALENCE (NEWS_MARK(2),NEWS_FORMAT) DO I=1,2 IF (NEWS_TAG(3,I,ISUB).GT.0) THEN CALL LIB$FREE_VM( & (NEWS_TAG(2,I,ISUB)-NEWS_TAG(1,I,ISUB))/8+1,NEWS_TAG(3,I,ISUB)) NEWS_TAG(3,I,ISUB) = 0 NEWS_NUMBER = NEWS_FOLDER_NUMBER NEWS_REC = -32768 DO WHILE (REC_LOCK(IER)) READ (23,KEYGT=NEWS_MARK(1),IOSTAT=IER) NEWS_MARK IF (IER.EQ.0.AND.NEWS_NUMBER.EQ.NEWS_FOLDER_NUMBER) THEN DELETE (UNIT=23) L = REC_LOCK(IER) END IF END DO IF (IER.EQ.0) UNLOCK 23 END IF DO J=I,FOLDER_MAX-2 CALL LIB$MOVC3(16,NEWS_TAG(1,I,J+1),NEWS_TAG(1,I,J)) END DO DO J=1,4 NEWS_TAG(J,I,FOLDER_MAX-1) = 0 END DO END DO RETURN END SUBROUTINE GET_PREVIOUS_TAG(FN,IER,BULL_READ,TAG_TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /TAGS/ BULL_TAG,READ_TAG,BULL_NEWS_TAG CHARACTER*8 PREV_MSG_KEY IER = 36 IF (REMOTE_SET.GE.3) THEN INQUIRE (UNIT=2,OPENED=CLOSE_IT) CLOSE_IT = .NOT.CLOSE_IT IF (CLOSE_IT) CALL OPEN_BULLDIR_SHARED SUBNUM = NEWS_FIND_SUBSCRIBE() DO WHILE (IER.NE.0.AND.MSG_NUM.GT.F_START) MSG_NUM = MSG_NUM - 1 CALL GET_THIS_TAG(FN,IER,MSG_NUM,TAG_TYPE) IF (IER.EQ.0) THEN TMP_MSG_NUM = MSG_NUM CALL READDIR(TMP_MSG_NUM,IER1) IF (IER1.NE.MSG_NUM+1) THEN IF (.NOT.BTEST(READ_TAG,3)) THEN CALL DEL_NEWS_TAG(TAG_TYPE,TMP_MSG_NUM,SUBNUM) END IF IER = 36 END IF END IF END DO BULL_READ = MSG_NUM IF (CLOSE_IT) CALL CLOSE_BULLDIR ELSE IF (MSG_NUM.EQ.0) RETURN SAVE_MSG_NUM = MSG_NUM PREV_MSG_NUM = MSG_NUM MSG_NUM = 0 MSG_KEY = BULLDIR_HEADER IER = 0 DO WHILE (IER.EQ.0.AND.MSG_NUM.LT.SAVE_MSG_NUM) IF (MSG_NUM.GT.0) THEN PREV_MSG_KEY = MSG_KEY PREV_MSG_NUM = MSG_NUM END IF CALL GET_NEXT_TAG(FN,IER,BULL_READ,TAG_TYPE) END DO IF (PREV_MSG_NUM.LT.SAVE_MSG_NUM) THEN MSG_NUM = PREV_MSG_NUM MSG_KEY = PREV_MSG_KEY CALL GET_THIS_OR_NEXT_TAG(FN,IER,BULL_READ,TAG_TYPE) ELSE IER = 36 END IF END IF RETURN END SUBROUTINE DECREMENT_MSG_KEY IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' 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 RETURN END SUBROUTINE SET_GENERIC(GENERIC) C C SUBROUTINE SET_GENERIC C C FUNCTION: Enables or disables "GENERIC" display, i.e. displaying C general bulletins continually for a certain amount of days. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER IF (.NOT.SETPRV_PRIV()) THEN WRITE (6,'( & '' ERROR: No privs to change GENERIC.'')') RETURN END IF IER = CLI$GET_VALUE('USERNAME',TEMP_USER) CALL OPEN_BULLUSER_SHARED CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) IF (IER.EQ.0) THEN IF (GENERIC) THEN IF (CLI$PRESENT('DAYS')) THEN IER = CLI$GET_VALUE('DAYS',BULL_PARAMETER) CALL LIB$MOVC3(4,%REF(BULL_PARAMETER),NEW_FLAG(2)) ELSE NEW_FLAG(2) = ' 7' END IF ELSE NEW_FLAG(2) = 0 END IF REWRITE (4) TEMP_USER//USER_ENTRY(13:) ELSE WRITE (6,'('' ERROR: Specified username not found.'')') END IF CALL CLOSE_BULLUSER RETURN END SUBROUTINE SET_BRIEF_CONTINUOUS(BRIEF_CONTINUOUS) C C SUBROUTINE SET_BRIEF_CONTINUOUS C C FUNCTION: Enables or disables "BRIEF_CONTINUOUS" display, i.e. displaying C the brief message continually until the new messages have been read. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' CALL OPEN_BULLUSER_SHARED CALL READ_USER_FILE_KEYNAME(USERNAME,IER) IF (BRIEF_CONTINUOUS) THEN NEW_FLAG(2) = -1 ELSE NEW_FLAG(2) = 0 END IF IF (IER.EQ.0) REWRITE (4) USER_ENTRY CALL CLOSE_BULLUSER RETURN END SUBROUTINE SET_LOGIN(LOGIN) C C SUBROUTINE SET_LOGIN C C FUNCTION: Enables or disables bulletin display at login. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' CHARACTER TODAY*24 DIMENSION NOLOGIN_BTIM(2) CALL SYS$ASCTIM(,TODAY,,) ! Get the present time IF (.NOT.SETPRV_PRIV()) THEN WRITE (6,'( & '' ERROR: No privs to change LOGIN.'')') RETURN END IF IER = CLI$GET_VALUE('USERNAME',TEMP_USER) CALL OPEN_BULLUSER_SHARED CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) IF (IER.EQ.0) THEN IF (LOGIN.AND.COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN CALL SYS_BINTIM(TODAY,LOGIN_BTIM) ELSE IF (.NOT.LOGIN) THEN LOGIN_BTIM(1) = NOLOGIN_BTIM(1) LOGIN_BTIM(2) = NOLOGIN_BTIM(2) END IF REWRITE (4) TEMP_USER//USER_ENTRY(13:) ELSE WRITE (6,'('' ERROR: Specified username not found.'')') END IF CALL CLOSE_BULLUSER RETURN END SUBROUTINE GET_UAF(USERNAME,USER,GROUP,ACCOUNT,FLAGS,IER) IMPLICIT INTEGER (A-Z) CHARACTER USERNAME*(*),ACCOUNT*(*) INCLUDE '($UAIDEF)' INTEGER*2 UIC(2) CALL INIT_ITMLST CALL ADD_2_ITMLST(4,UAI$_FLAGS,%LOC(FLAGS)) CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) CALL END_ITMLST(GETUAI_ITMLST) IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) USER = UIC(1) GROUP = UIC(2) RETURN END SUBROUTINE DCLEXH(EXIT_ROUTINE) IMPLICIT INTEGER (A-Z) INTEGER*4 EXBLK(4) EXBLK(2) = EXIT_ROUTINE EXBLK(3) = 1 EXBLK(4) = %LOC(EXBLK(4)) CALL SYS$DCLEXH(EXBLK(1)) RETURN END SUBROUTINE SENDMAIL(FILE,SENDTO,SUBJECT,STATUS) IMPLICIT INTEGER (A-Z) INCLUDE '($MAILDEF)' INCLUDE 'BULLUSER.INC' CHARACTER*(*) FILE,SENDTO,SUBJECT EXTERNAL MAIL_ERROR CALL SYS$SETAST(%VAL(1)) CALL DISABLE_PRIVS DO WHILE (INDEX(SENDTO,'""').GT.0) SENDTO = SENDTO(:INDEX(SENDTO,'""'))// & SENDTO(INDEX(SENDTO,'""')+2:) END DO DO WHILE (INDEX(SUBJECT,'""').GT.0) SUBJECT = SUBJECT(:INDEX(SUBJECT,'""'))// & SUBJECT(INDEX(SUBJECT,'""')+2:) END DO C = 0 CALL LIB$ESTABLISH(MAIL_ERROR) STATUS = MAIL$SEND_BEGIN(C,0,0) IF (.NOT.STATUS) GO TO 100 J = 1 DO WHILE (J.LE.TRIM(SENDTO)) I = INDEX(SENDTO(J:),',') - 1 IF (I.EQ.-1) I = TRIM(SENDTO(J:)) CALL INIT_ITMLST CALL ADD_2_ITMLST(I,MAIL$_SEND_USERNAME,%LOC(SENDTO(J:))) CALL END_ITMLST(ADDRESS_ITMLST) STATUS = MAIL$SEND_ADD_ADDRESS(C,%VAL(ADDRESS_ITMLST),0) IF (.NOT.STATUS) GO TO 100 J = J + I IF (SENDTO(J:J).EQ.',') J = J + 1 END DO CALL INIT_ITMLST CALL ADD_2_ITMLST(TRIM(SUBJECT),MAIL$_SEND_SUBJECT & ,%LOC(SUBJECT)) C IF (SETPRV_PRIV()) THEN C CALL ENABLE_PRIVS C CALL ADD_2_ITMLST C & (TRIM(USERNAME),MAIL$_SEND_FROM_LINE,%LOC(USERNAME)) C CALL DISABLE_PRIVS C END IF CALL ADD_2_ITMLST(TRIM(SENDTO),MAIL$_SEND_TO_LINE,%LOC(SENDTO)) CALL END_ITMLST(ATTRIBUTE_ITMLST) STATUS = MAIL$SEND_ADD_ATTRIBUTE(C,%VAL(ATTRIBUTE_ITMLST),0) IF (.NOT.STATUS) GO TO 100 CALL INIT_ITMLST CALL ADD_2_ITMLST(TRIM(FILE),MAIL$_SEND_FILENAME,%LOC(FILE)) CALL END_ITMLST(BODYPART_ITMLST) STATUS = MAIL$SEND_ADD_BODYPART(C,%VAL(BODYPART_ITMLST),0) IF (.NOT.STATUS) GO TO 100 STATUS = MAIL$SEND_MESSAGE(C,0,0) IF (.NOT.STATUS) GO TO 100 STATUS = MAIL$SEND_END(C,0,0) IF (.NOT.STATUS) GO TO 100 100 CALL ENABLE_PRIVS CALL LIB$REVERT RETURN END FUNCTION MAIL_ERROR(SIGARGS,MECHARGS) MAIL_ERROR = .TRUE. CALL SYS$PUTMSG(SIGARGS,,) RETURN END SUBROUTINE SET_NEWS IMPLICIT INTEGER (A-Z) INCLUDE '($SSDEF)' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER EXTERNAL CLI$_NEGATED,CLI$_ABSENT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /NEXT/ NEXT COMMON /NEWSDIR_FILE/ BULLNEWSDIR_FILE CHARACTER*80 BULLNEWSDIR_FILE DIMENSION EXPIRED(2) CHARACTER GROUP*44,FOLDER_SAVE*44,NEW_NEWS_ACCESS*132 CHARACTER NEWS_ACCESS*132 IF (.NOT.SETPRV_PRIV()) THEN WRITE (6,'('' ERROR: No privs to change NEWS.'')') RETURN END IF ENTRY SHOW_NEWS LIMIT = -2 IF (CLI$GET_VALUE('LIMIT',BULL_PARAMETER,LEN_P)) THEN IER = OTS$CVT_TI_L(BULL_PARAMETER(:LEN_P),LIMIT,,%VAL(1)) IF (.NOT.IER.OR.LIMIT.LT.-1) THEN WRITE (6,'('' ERROR: Invalid value for LIMIT.'')') RETURN END IF END IF EXPIRE = -1 IF (CLI$GET_VALUE('EXPIRATION',BULL_PARAMETER,LEN_P)) THEN IER = OTS$CVT_TI_L(BULL_PARAMETER(:LEN_P),EXPIRE,,%VAL(1)) IF (.NOT.IER.OR.(EXPIRE.LE.0.AND.CLI$PRESENT('DEFAULT'))) THEN WRITE (6,'('' ERROR: Invalid value for EXPIRATION.'')') RETURN END IF END IF IF (.NOT.(CLI$PRESENT('DEFAULT').OR.CLI$PRESENT('CLASS').OR. & CLI$PRESENT('SHOW_FOLDER')).AND.REMOTE_SET.LT.3) THEN WRITE (6,'('' ERROR: You have not selected a news group.'')') RETURN END IF CALL OPEN_BULLNEWS_SHARED ! Open folder file IF (CLI$PRESENT('DEFAULT')) THEN CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER) ELSE IF (CLI$GET_VALUE('CLASS',BULL_PARAMETER,LEN_P)) THEN BULL_PARAMETER = BULL_PARAMETER(:LEN_P)//'.' CALL STR$UPCASE(BULL_PARAMETER,BULL_PARAMETER) LEN_P = LEN_P + 1 IF (LEN_P.GT.LEN(FOLDER)) THEN WRITE (6,'('' ERROR: Class name too long.'')') CALL CLOSE_BULLNEWS RETURN END IF GROUP = BULL_PARAMETER(:LEN_P) LG = LEN_P CALL READ_FOLDER_FILE_KEYNAME_TEMP(BULL_PARAMETER(:LEN_P), & NEWCLASS) IF (CLI$PRESENT('DELETE')) THEN IF (NEWCLASS.NE.0) THEN WRITE (6,'('' ERROR: Class not found.'')') ELSE DELETE (7) WRITE (6,'('' Class deleted.'')') END IF IF (BTEST(FOLDER1_FLAG,0)) THEN OPEN (UNIT=3,FILE=NEWS_ACCESS(FOLDER1_DESCRIP), & STATUS='OLD',IOSTAT=IER) CLOSE (UNIT=3,DISPOSE='DELETE') END IF RETURN ELSE IF (NEWCLASS.NE.0) THEN CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER) DO WHILE (IER.EQ.0) DO WHILE (REC_LOCK(IER)) READ (7,KEY=NEWS_F1_COUNT,KEYID=1,IOSTAT=IER) END DO IF (IER.EQ.0) NEWS_F1_COUNT = NEWS_F1_COUNT + 1 END DO FOLDER1_FLAG = NEWS_FLAG_DEFAULT FOLDER1_BBEXPIRE = NEWS_EXPIRE_DEFAULT F1_EXPIRE_LIMIT = NEWS_EXPIRE_LIMIT_DEFAULT CALL SYS_BINTIM('6-NOV-2956 00:00:00.00',EXPIRED) CALL GET_MSGKEY(EXPIRED,NEWS_F1_EXPIRED_DATE) CALL SYS_BINTIM('5-NOV-1956 00:00:00.00',EXPIRED) CALL GET_MSGKEY(EXPIRED,NEWS_F1_CREATED_DATE) FOLDER1_NUMBER = NEWS_F1_COUNT FOLDER1 = BULL_PARAMETER FOLDER1_FLAG = IBSET(FOLDER1_FLAG,10) CALL WRITE_FOLDER_FILE_TEMP(IER) IF (IER.NE.0) THEN CALL CLOSE_BULLNEWS WRITE (6,'('' Unable to add entry.'')') RETURN END IF TEMP = FOLDER1_NUMBER CALL READ_FOLDER_FILE_KEYNUM_TEMP(1000,IER) NEWS_F1_COUNT = TEMP REWRITE (7) NEWS_FOLDER1_COM CALL READ_FOLDER_FILE_KEYNUM_TEMP(TEMP,IER) END IF ELSE IF (CLI$GET_VALUE('SHOW_FOLDER',FOLDER1).EQ. & %LOC(CLI$_ABSENT)) FOLDER1 = FOLDER IF (INDEX(FOLDER1,'.').GT.0) CALL LOWERCASE(FOLDER1) CALL READ_FOLDER_FILE_KEYNAME_TEMP(FOLDER1,IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Invalid news group.'')') CALL CLOSE_BULLNEWS RETURN END IF END IF IF (EXPIRE.GE.0) FOLDER1_BBEXPIRE = EXPIRE IF (LIMIT.GE.-1) F1_EXPIRE_LIMIT = LIMIT CLASS = CLI$PRESENT('CLASS') DEFAULT = CLI$PRESENT('DEFAULT') ALL = CLI$PRESENT('ALL') IF (CLASS.AND.INDEX(GROUP(:LG-1),'.').GT.0) ALL = .TRUE. DISABLE = CLI$PRESENT('DISABLE') ENABLE = CLI$PRESENT('ENABLE') PRIVATE = CLI$PRESENT('PRIVATE') NOPRIVATE = CLI$PRESENT('PRIVATE').EQ.%LOC(CLI$_NEGATED) STORED = 0 IF (CLI$PRESENT('STORED')) THEN STORED = 1 IF (.NOT.(CLASS.OR.DEFAULT).AND..NOT.BTEST(FOLDER1_FLAG,8)) THEN F1_LAST = 0 F1_COUNT = 0 F1_START = 0 F1_NBULL = 0 NEWS_F1_FIRST = 0 NEWS_F1_END = 0 END IF FOLDER1_FLAG = IBSET(FOLDER1_FLAG,8) ELSE IF (CLI$PRESENT('STORED').EQ.%LOC(CLI$_NEGATED)) THEN STORED = 2 CALL GET_INPUT_PROMPT(BULL_PARAMETER,LEN_P, & 'Are you sure you want to remove stored setting? '// & '(Y/N with N as default): ') IF (BULL_PARAMETER(:1).NE.'y'.AND.BULL_PARAMETER(:1).NE.'Y') THEN WRITE (6,'('' Stored setting was not removed.'')') CALL CLOSE_BULLNEWS RETURN END IF IF (DEFAULT) THEN CALL LIB$DELETE_FILE(NEWS_DIRECTORY(:TRIM(NEWS_DIRECTORY)) & //'[.BULLNEWS*]*.*;*') CALL LIB$DELETE_FILE(NEWS_DIRECTORY(:TRIM(NEWS_DIRECTORY)) & //'BULLNEWS*.DIR;*') ELSE IF (.NOT.CLASS.AND.BTEST(FOLDER1_FLAG,8)) THEN CALL CLOSE_BULLNEWS FOLDER_SAVE = FOLDER IF (FOLDER_NUMBER.NE.FOLDER1_NUMBER) THEN FOLDER_NUMBER = FOLDER1_NUMBER CALL SELECT_FOLDER(.FALSE.,IER) END IF FOLDER = FOLDER_SAVE CALL OPEN_BULLDIR CALL CLOSE_BULLDIR_DELETE CALL OPEN_BULLNEWS_SHARED CALL READ_FOLDER_FILE_KEYNUM_TEMP(NEWS_FOLDER_NUMBER,IER) F1_START = 0 F1_NBULL = 0 F1_COUNT = 0 F1_LAST = 0 END IF FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,8) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,13) END IF IF (NOPRIVATE.AND..NOT.DEFAULT) THEN OPEN (UNIT=3,FILE=NEW_NEWS_ACCESS(FOLDER1_DESCRIP), & STATUS='OLD',IOSTAT=IER) CLOSE (UNIT=3,DISPOSE='DELETE') FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) END IF IF (PRIVATE.AND..NOT.BTEST(FOLDER1_FLAG,0)) THEN CALL SET_PROTECTION OPEN (UNIT=3,FILE=NEWS_ACCESS(FOLDER1_DESCRIP), & STATUS='OLD',IOSTAT=IER) CLOSE (UNIT=3) IF (IER.NE.0) THEN OPEN (UNIT=3,FILE=NEW_NEWS_ACCESS(FOLDER1_DESCRIP), & STATUS='NEW',IOSTAT=IER) CLOSE (UNIT=3) END IF CALL RESET_PROTECTION FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) END IF IF (ENABLE) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,9) IF (DISABLE) FOLDER1_FLAG = IBSET(FOLDER1_FLAG,9) FLAG = ENABLE.OR.DISABLE.OR.STORED.NE.0.OR.PRIVATE.OR.NOPRIVATE CALL REWRITE_FOLDER_FILE_TEMP(IER) IF (DEFAULT.OR.(CLASS.AND.(STREQ(GROUP(:LG),FOLDER(:LG)) & .OR.STREQ(GROUP(:LG-1),FOLDER)))) THEN NEWS_FLAG_DEFAULT = NEWS_F1_FLAG NEWS_EXPIRE_DEFAULT = NEWS_F1_EXPIRE NEWS_EXPIRE_LIMIT_DEFAULT = NEWS_F1_EXPIRE_LIMIT END IF CALL OTS$CVT_L_TI(FOLDER1_BBEXPIRE,BULL_PARAMETER,,,) IF (DEFAULT.OR.CLASS) THEN IF (CLASS) THEN WRITE (6,'('' For class '',A,'':'')') GROUP(:LG) END IF IF (BTEST(FOLDER1_FLAG,9)) WRITE (6,'('' Disable is set.'')') IF (BTEST(FOLDER1_FLAG,8)) THEN WRITE (6,'('' Default is stored.'')') ELSE WRITE (6,'('' Default is not stored.'')') END IF CALL OTS$CVT_L_TI(FOLDER1_BBEXPIRE,BULL_PARAMETER,,,) IF (FOLDER1_BBEXPIRE.GT.0) THEN WRITE (6,'('' Default expiration for stored groups is '' & ,A,''.'')') BULL_PARAMETER(FIRST_ALPHA(BULL_PARAMETER):) ELSE IF (CLASS) THEN WRITE (6,'('' Expiration is DEFAULT value.'')') ELSE WRITE (6,'('' Default expiration for stored groups is '' & ,''14.'')') END IF CALL OTS$CVT_L_TI(F1_EXPIRE_LIMIT,BULL_PARAMETER,,,) IF (F1_EXPIRE_LIMIT.GT.0) THEN WRITE (6,'('' Default expiration limit is '',A,''.'')') & BULL_PARAMETER(FIRST_ALPHA(BULL_PARAMETER):) ELSE IF (CLASS.AND.F1_EXPIRE_LIMIT.EQ.0) THEN WRITE (6,'('' Expiration limit is DEFAULT value.'')') ELSE WRITE (6,'('' There is no default expiration limit.'')') END IF IF (BTEST(FOLDER1_FLAG,0)) THEN WRITE (6,'('' Private is set.'')') END IF ELSE IF (BTEST(FOLDER1_FLAG,9)) THEN FOLDER1_NAME = FOLDER1_DESCRIP(:INDEX(FOLDER1_DESCRIP,' ')-1) WRITE (6,'('' For news group '',A,'':'')') & FOLDER1_NAME(:TRIM(FOLDER1_NAME)) WRITE (6,'('' Disable is set.'')') ELSE FOLDER1_NAME = FOLDER1_DESCRIP(:INDEX(FOLDER1_DESCRIP,' ')-1) WRITE (6,'('' For news group '',A,'':'')') & FOLDER1_NAME(:TRIM(FOLDER1_NAME)) IF (BTEST(FOLDER1_FLAG,8)) THEN WRITE (6,'('' News group is stored.'')') CALL OTS$CVT_L_TI(FOLDER1_BBEXPIRE,BULL_PARAMETER,,,) IF (FOLDER1_BBEXPIRE.GT.0) THEN WRITE (6,'('' Expiration is '',A,''.'')') & BULL_PARAMETER(FIRST_ALPHA(BULL_PARAMETER):) ELSE WRITE (6,'('' Expiration is DEFAULT value.'')') END IF ELSE WRITE (6,'('' News group is not stored.'')') END IF CALL OTS$CVT_L_TI(F1_EXPIRE_LIMIT,BULL_PARAMETER,,,) IF (F1_EXPIRE_LIMIT.GT.0) THEN WRITE (6,'('' Expiration limit is '',A,''.'')') & BULL_PARAMETER(FIRST_ALPHA(BULL_PARAMETER):) ELSE IF (F1_EXPIRE_LIMIT.EQ.0) THEN WRITE (6,'('' Expiration limit is DEFAULT value.'')') ELSE WRITE (6,'('' There is no expiration limit.'')') END IF IF (BTEST(FOLDER1_FLAG,1)) THEN WRITE (6,'('' DUMP has been set.'')') END IF IF (BTEST(FOLDER1_FLAG,0)) THEN WRITE (6,'('' Private is set.'')') END IF NOTIFY_FLAG_NEWS = .FALSE. SET_FLAG_NEWS = .FALSE. BRIEF_FLAG_NEWS = .FALSE. CALL OPEN_BULLINF_SHARED DO WHILE (REC_LOCK(IER1)) READ (9,KEY='*DEFAULT',IOSTAT=IER1) TEMP_USER,INF_REC END DO IF (IER1.EQ.0) THEN I = 1 DO WHILE (INF_REC2(1,I).NE.NEWS_FOLDER1_NUMBER & .AND.I.LE.FOLDER_MAX-1) I = I + 1 END DO IF (I.LE.FOLDER_MAX-1) THEN NOTIFY_FLAG_NEWS = BTEST(INF_REC2(2,I),13) SET_FLAG_NEWS = BTEST(INF_REC2(2,I),14) BRIEF_FLAG_NEWS = BTEST(INF_REC2(2,I),15) WRITE (6,'('' This is a default news group.'')') ELSE IER1 = 2 END IF END IF NOTIFY_PERM_FLAG_NEWS = .FALSE. SET_PERM_FLAG_NEWS = .FALSE. BRIEF_PERM_FLAG_NEWS = .FALSE. DO WHILE (REC_LOCK(IER2)) READ (9,KEY='*PERM',IOSTAT=IER2) TEMP_USER,INF_REC END DO IF (IER2.EQ.0) THEN I = 1 DO WHILE (INF_REC2(1,I).NE.NEWS_FOLDER1_NUMBER & .AND.I.LE.FOLDER_MAX-1) I = I + 1 END DO IF (I.LE.FOLDER_MAX-1) THEN NOTIFY_PERM_FLAG_NEWS = BTEST(INF_REC2(2,I),13) SET_PERM_FLAG_NEWS = BTEST(INF_REC2(2,I),14) BRIEF_PERM_FLAG_NEWS = BTEST(INF_REC2(2,I),15) WRITE (6,'('' This is a permanent news group.'')') END IF END IF PERM = .FALSE. IF (SET_FLAG_NEWS) THEN IF (BRIEF_FLAG_NEWS) THEN IF (SET_PERM_FLAG_NEWS.AND.BRIEF_PERM_FLAG_NEWS) THEN PERM = .TRUE. WRITE (6,'('' Default is BRIEF, which is permanent.'')') ELSE WRITE (6,'('' Default is BRIEF.'')') END IF ELSE IF (SET_PERM_FLAG_NEWS.AND..NOT.BRIEF_PERM_FLAG_NEWS) THEN PERM = .TRUE. WRITE (6,'('' Default is READNEW, which is permanent.'')') ELSE WRITE (6,'('' Default is READNEW.'')') END IF END IF ELSE IF (BRIEF_FLAG_NEWS) THEN IF (.NOT.SET_PERM_FLAG_NEWS.AND.BRIEF_PERM_FLAG_NEWS) THEN PERM = .TRUE. WRITE (6,'('' Default is SHOWNEW, which is permanent.'')') ELSE WRITE (6,'('' Default is SHOWNEW.'')') END IF END IF IF (.NOT.PERM) THEN IF (SET_PERM_FLAG_NEWS.AND.BRIEF_PERM_FLAG_NEWS) THEN WRITE (6,'('' BRIEF is the permanent setting.'')') ELSE IF (SET_PERM_FLAG_NEWS.AND..NOT.BRIEF_PERM_FLAG_NEWS) THEN WRITE (6,'('' READNEW is the permanent setting.'')') ELSE IF (BRIEF_PERM_FLAG_NEWS.AND..NOT.SET_PERM_FLAG_NEWS) THEN WRITE (6,'('' SHOWNEW is the permanent setting.'')') END IF END IF IF (NOTIFY_FLAG_NEWS) THEN IF (NOTIFY_PERM_FLAG_NEWS) THEN WRITE (6,'('' Default is NOTIFY, which is permanent.'')') ELSE IF (IER1.EQ.0) THEN WRITE (6,'('' Default is NOTIFY.'')') END IF ELSE IF (NOTIFY_PERM_FLAG_NEWS) THEN WRITE (6,'('' NOTIFY is permanent.'')') ELSE IF (IER1.EQ.0) THEN WRITE (6,'('' Default is NONOTIFY.'')') END IF CALL CLOSE_BULLINF END IF IF (CLI$PRESENT('FULL').AND.BTEST(FOLDER1_FLAG,0)) THEN CALL CHKACL(NEWS_ACCESS(FOLDER1_DESCRIP),IER) IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN IF (SETPRV_PRIV()) THEN READ_ACCESS = 1 WRITE_ACCESS = 1 ELSE CALL CHECK_ACCESS(NEWS_ACCESS(FOLDER1_DESCRIP), & USERNAME,READ_ACCESS,WRITE_ACCESS) END IF IF (WRITE_ACCESS) CALL SHOWACL(NEWS_ACCESS(FOLDER1_DESCRIP)) ELSE IF (IER.EQ.(SS$_ACLEMPTY.OR.SS$_NORMAL)) THEN WRITE (6,'('' Access is not limited.'')') END IF END IF IF (EXPIRE.LT.0.AND.LIMIT.LT.-1.AND..NOT.FLAG.AND. & (.NOT.CLASS.OR.NEWCLASS.EQ.0)) THEN CALL CLOSE_BULLNEWS RETURN END IF IF (CLASS.AND.(ALL.OR.FLAG)) THEN WRITE (6,'('' Modifying news groups...'')') FOLDER_SAVE = FOLDER CALL LOWERCASE(GROUP) CALL READ_FOLDER_FILE_KEYNAME_TEMP(GROUP(:LG-1),IER) IF (IER.NE.0.OR.GROUP(:LG-1).NE.FOLDER1) THEN CALL READ_FOLDER_FILE_KEYNAMEGE_TEMP(GROUP(:LG),IER) END IF FOUND = .FALSE. MODALL = INDEX(GROUP,'.').NE.LG DO WHILE (IER.EQ.0.AND.(GROUP(:LG).EQ.FOLDER1(:LG).OR. & GROUP(:LG).EQ.FOLDER1(:TRIM(FOLDER1))//'.')) FOUND = .TRUE. IF (STORED.EQ.2.AND.BTEST(FOLDER1_FLAG,8)) THEN CALL CLOSE_BULLNEWS FOLDER_NUMBER = FOLDER1_NUMBER CALL SELECT_FOLDER(.FALSE.,IER) IF (IER) THEN CALL OPEN_BULLDIR CALL CLOSE_BULLDIR_DELETE END IF CALL OPEN_BULLNEWS_SHARED CALL READ_FOLDER_FILE_KEYNUM_TEMP(FOLDER1_NUMBER,IER) F1_LAST = 0 F1_COUNT = 0 F1_START = 0 F1_NBULL = 0 FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,8) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,13) ELSE IF (STORED.EQ.1.AND..NOT.BTEST(FOLDER1_FLAG,8)) THEN F1_LAST = 0 F1_COUNT = 0 F1_START = 0 F1_NBULL = 0 NEWS_F1_FIRST = 0 NEWS_F1_END = 0 FOLDER1_FLAG = IBSET(FOLDER1_FLAG,8) END IF IF (EXPIRE.GE.0) FOLDER1_BBEXPIRE = 0 IF (EXPIRE.GE.0.AND.MODALL) FOLDER1_BBEXPIRE = EXPIRE IF (LIMIT.GE.0) F1_EXPIRE_LIMIT = 0 IF (LIMIT.GE.0.AND.MODALL) F1_EXPIRE_LIMIT = LIMIT IF (ENABLE) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,9) IF (DISABLE) FOLDER1_FLAG = IBSET(FOLDER1_FLAG,9) IF (PRIVATE) FOLDER1_FLAG = IBSET(FOLDER1_FLAG,0) IF (NOPRIVATE) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,0) CALL REWRITE_FOLDER_FILE_TEMP(IER) CALL READ_FOLDER_FILE_KEYNAMEGT_TEMP(FOLDER1,IER) END DO IF (.NOT.FOUND) THEN WRITE (6,'('' ERROR: No news groups match class name.'')') WRITE (6,'('' ERROR: Class has been removed.'')') CALL OPEN_BULLNEWS_SHARED CALL STR$UPCASE(GROUP,GROUP) CALL READ_FOLDER_FILE_KEYNAME_TEMP(GROUP(:LG),IER) DELETE (7) CALL CLOSE_BULLNEWS OPEN (UNIT=3,FILE=NEW_NEWS_ACCESS(FOLDER1_DESCRIP), & STATUS='OLD',IOSTAT=IER) CLOSE (UNIT=3,DISPOSE='DELETE') END IF IF (FOLDER_SAVE.NE.FOLDER) THEN FOLDER_NUMBER = -1 FOLDER1 = FOLDER_SAVE CALL SELECT_FOLDER(.FALSE.,IER) IF (.NOT.IER) THEN FOLDER_NUMBER = 0 CALL SELECT_FOLDER(.FALSE.,IER) WRITE (6,'('' Resetting to '',A,'' folder.'')') & FOLDER(:TRIM(FOLDER)) END IF RETURN END IF ELSE IF (DEFAULT.AND.(ALL.OR.FLAG)) THEN WRITE (6,'('' Modifying news groups.'', & '' This will take a while...'')') IER = 0 DO WHILE (IER.EQ.0) CALL READ_FOLDER_FILE_TEMP(IER) IF (EXPIRE.GE.0) FOLDER1_BBEXPIRE = 0 IF (LIMIT.GE.0) F1_EXPIRE_LIMIT = 0 IF ((STORED.EQ.1.AND..NOT.BTEST(FOLDER1_FLAG,8)).OR. & (STORED.EQ.2.AND.BTEST(FOLDER1_FLAG,8))) THEN F1_LAST = 0 F1_COUNT = 0 F1_START = 0 F1_NBULL = 0 NEWS_F1_FIRST = 0 NEWS_F1_END = 0 END IF IF (STORED.EQ.1) FOLDER1_FLAG = IBSET(FOLDER1_FLAG,8) IF (STORED.EQ.2) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,8) IF (STORED.EQ.2) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,13) IF (ENABLE) FOLDER1_FLAG = IBCLR(FOLDER1_FLAG,9) IF (DISABLE) FOLDER1_FLAG = IBSET(FOLDER1_FLAG,9) CALL REWRITE_FOLDER_FILE_TEMP(IER) END DO END IF FOLDER_NUMBER = -1 FOLDER1 = FOLDER CALL SELECT_FOLDER(.FALSE.,IER) IF (.NOT.IER) THEN FOLDER_NUMBER = 0 CALL SELECT_FOLDER(.FALSE.,IER) WRITE (6,'('' Resetting to '',A,'' folder.'')') & FOLDER(:TRIM(FOLDER)) END IF CALL CLOSE_BULLNEWS RETURN END SUBROUTINE INCLUDE(EXCLUDE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(INPUT_LENGTH) OLD_BUFFER COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM CHARACTER TODAY*24 DIMENSION BTIM(2) CALL SYS$ASCTIM(,TODAY,,) ! Get the present time L_TODAY = TRIM(TODAY) ALL = CLI$PRESENT('ALL') FULL = CLI$PRESENT('FULL') IF (.NOT.CLI$GET_VALUE('P1',INPUT,LEN_P).AND..NOT.ALL) THEN IF (BULL_POINT.EQ.0) THEN ! If no bulletin has been read WRITE(6,'('' ERROR: You have not read any message.'')') RETURN ! And return END IF CALL OPEN_BULLDIR_SHARED BULL_USER_CUSTOM = IBCLR(BULL_USER_CUSTOM,1) CALL READDIR(BULL_POINT,IER) ! Get info for specified bulletin BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,1) IF (IER.NE.BULL_POINT+1) THEN ! Was bulletin found? WRITE(6,'('' ERROR: Specified message was not found.'')') CALL CLOSE_BULLDIR ! If not, then error out RETURN END IF CALL OPEN_BULLFIL_SHARED ! Open BULLETIN file ILEN = LINE_LENGTH + 1 CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN IF (CLI$PRESENT('SUBJECT')) THEN CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN) ELSE INPUT = INPUT(7:) IF (INDEX(INPUT,'%"').GT.0) THEN INPUT = INPUT(INDEX(INPUT,'%"')+2:ILEN-1) END IF END IF ELSE INPUT = FROM END IF IF (CLI$PRESENT('SUBJECT')) THEN IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THEN INPUT = INPUT(7:) ELSE INPUT = DESCRIP END IF END IF LEN_P = TRIM(INPUT) CALL CLOSE_BULLFIL END IF IF (CLI$PRESENT('SUBJECT')) THEN INPUT = 'SUBJECT:'//INPUT LEN_P = LEN_P + 8 ELSE INPUT = 'FROM:'//INPUT LEN_P = LEN_P + 5 END IF IF (EXCLUDE) THEN INPUT = ':EXCLUDE:'//INPUT LEN_P = LEN_P + 9 ELSE INPUT = ':INCLUDE:'//INPUT LEN_P = LEN_P + 9 END IF FLEN = TRIM(FOLDER_NAME) INPUT = FOLDER_NAME(:FLEN)//INPUT ILEN = FLEN + LEN_P DISABLE = CLI$PRESENT('DISABLE') EXC = -1 IER = CLI$GET_VALUE('LIMIT',BULL_PARAMETER,LEN_P) IF (IER) THEN DECODE(LEN_P,'(I)',BULL_PARAMETER,IOSTAT=IER) EXC IF (EXC.LT.0.OR.EXC.GT.999.OR.IER.NE.0) THEN WRITE(6,'('' ERROR: Valid limit is 0-999.'')') RETURN END IF END IF CHECK_ONLY = .FALSE. GO TO 100 ENTRY CHECK_EXCLUDES CHECK_ONLY = .TRUE. DISABLE = .TRUE. LEN_P = 0 INPUT = ' ' ILEN = 1 100 IER = SYS_TRNLNM('BULL_USER_CUSTOM',BULL_PARAMETER) IF (.NOT.IER) BULL_PARAMETER = 'SYS$LOGIN:BULL.CUSTOM' CALL DISABLE_PRIVS OPEN(UNIT=3,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & STATUS='OLD',SHARED,IOSTAT=IER1,RECL=INPUT_LENGTH) OPEN(UNIT=4,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & DISPOSE='DELETE',CARRIAGECONTROL='LIST',STATUS='NEW', & SHARED,IOSTAT=IER,RECL=INPUT_LENGTH) CALL ENABLE_PRIVS IF (IER.NE.0) THEN CLOSE (UNIT=3) WRITE(6,'('' ERROR: Error in opening new custom file.'')') RETURN END IF IF (IER1.NE.0) THEN IF (.NOT.DISABLE.AND.LEN_P.GT.0) THEN CALL ADD_EXCL(INPUT,ILEN,EXC) WRITE (4,'(A)',IOSTAT=IER) INPUT(:ILEN) END IF CLOSE (UNIT=4,DISPOSE='SAVE') RETURN END IF IER = 0 CONVERT = .FALSE. DO WHILE (IER.EQ.0) READ (3,'(Q,A)',IOSTAT=IER) OLEN,OLD_BUFFER IF (IER.EQ.0) THEN IF (INDEX(OLD_BUFFER(FLEN+2:),'defaults').EQ.1.AND.FULL & .AND.INPUT(:FLEN).EQ.OLD_BUFFER(:MIN(FLEN,OLEN))) THEN I = INDEX(OLD_BUFFER,':kill') IF (DISABLE.AND.I.GT.0) THEN IF (I.GT.FLEN-1.OR.OLEN.GT.I+4) THEN OLD_BUFFER = OLD_BUFFER(:I-1)//OLD_BUFFER(I+5:) WRITE (4,'(A)',IOSTAT=IER) OLD_BUFFER(:OLEN-5) END IF ELSE IF (.NOT.DISABLE.AND.I.EQ.0) THEN OLD_BUFFER = OLD_BUFFER(:OLEN)//':kill' WRITE (4,'(A)',IOSTAT=IER) OLD_BUFFER(:OLEN+5) FULL = .FALSE. END IF ELSE IF ((STREQ(OLD_BUFFER(:ILEN),INPUT(:ILEN)).AND. & OLD_BUFFER(ILEN+1:ILEN+1).EQ.':').OR. & (OLEN.LT.ILEN.AND.INPUT(OLEN+1:OLEN+1).EQ.':'.AND. & STREQ(OLD_BUFFER(:OLEN),INPUT(:OLEN)))) THEN CONTINUE ELSE IF (.NOT.(ALL.AND.INPUT(:FLEN+8).EQ. & OLD_BUFFER(:MIN(FLEN+8,OLEN)))) THEN IER2 = OLD_BUFFER(:1).EQ.':'.OR. & INDEX(OLD_BUFFER,':defaults:').GT.0 IF (.NOT.IER2) THEN CALL CHECK_EXCL(OLD_BUFFER,OLEN,EXC1,BLIMIT,BDATE,IER1) IF (IER1) IER2 = COMPARE_DATE(OLD_BUFFER(BDATE:OLEN-1) & ,' ').GT.-EXC1 CONVERT = .NOT.IER1 END IF IF (.NOT.IER1.OR.EXC1.EQ.0.OR.IER2) & WRITE (4,'(A)',IOSTAT=IER) OLD_BUFFER(:OLEN) END IF END IF END DO IF (.NOT.DISABLE) THEN IF (CLI$PRESENT('FULL')) THEN WRITE (4,'(A)',IOSTAT=IER) FOLDER_NAME(:FLEN)//':defaults:kill' ELSE CALL ADD_EXCL(INPUT,ILEN,EXC) WRITE (4,'(A)',IOSTAT=IER) INPUT(:ILEN) END IF END IF IF (CONVERT) THEN WRITE (6,'('' NOTE: See help on the new SET EXLIMIT command.'')') END IF CLOSE (UNIT=4,DISPOSE='SAVE') CLOSE (UNIT=3,DISPOSE='DELETE') CALL LIB$RENAME_FILE(BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & BULL_PARAMETER(:TRIM(BULL_PARAMETER))//';1') IF (.NOT.CHECK_ONLY) CALL CHECK_CUSTOM RETURN END SUBROUTINE UPDATE_EXCLUDE IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /SCRATCH_INCLUDE/ SCRATCH_B1,NINCLUDE,EXC_CHANGED DATA SCRATCH_B1/0/,NINCLUDE/0/,EXC_CHANGED/.FALSE./ CHARACTER TODAY*24 DIMENSION BTIM(2) IF (.NOT.EXC_CHANGED) RETURN EXC_CHANGED = .FALSE. CALL SYS$ASCTIM(,TODAY,,) ! Get the present time L_TODAY = TRIM(TODAY) IER = SYS_TRNLNM('BULL_USER_CUSTOM',BULL_PARAMETER) IF (.NOT.IER) BULL_PARAMETER = 'SYS$LOGIN:BULL.CUSTOM' CALL DISABLE_PRIVS OPEN(UNIT=3,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & STATUS='OLD',SHARED,IOSTAT=IER1,RECL=INPUT_LENGTH) OPEN(UNIT=4,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & DISPOSE='DELETE',CARRIAGECONTROL='LIST',STATUS='NEW', & SHARED,IOSTAT=IER,RECL=INPUT_LENGTH) CALL ENABLE_PRIVS IF (IER.NE.0) THEN CLOSE (UNIT=3) WRITE(6,'('' ERROR: Error in opening new custom file.'')') RETURN END IF IER = 0 DO WHILE (IER.EQ.0) READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT IF (.NOT.(IER.EQ.0.AND.FOLDER_NAME(:TRIM(FOLDER_NAME))//':'.EQ. & INPUT(:MIN(TRIM(FOLDER_NAME)+1,ILEN)).AND.INPUT(:1).NE.':' & .AND.INDEX(INPUT,':defaults:').EQ.0)) THEN IF (IER.EQ.0) WRITE (4,'(A)',IOSTAT=IER) INPUT(:ILEN) END IF END DO SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header DO I=1,NINCLUDE CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,INPUT) WRITE (4,'(A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) END DO CLOSE (UNIT=4,DISPOSE='SAVE') CLOSE (UNIT=3,DISPOSE='DELETE') CALL LIB$RENAME_FILE(BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & BULL_PARAMETER(:TRIM(BULL_PARAMETER))//';1') IF (.NOT.CHECK_ONLY) CALL CHECK_CUSTOM RETURN END SUBROUTINE SET_CUSTOM(PARAM) C C SUBROUTINE SET_CUSTOM C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /EXCLUDE_LIMIT/ EXCLUDE_LIMIT DATA EXCLUDE_LIMIT /0/ CHARACTER*(*) PARAM IER = SYS_TRNLNM('BULL_USER_CUSTOM',BULL_PARAMETER) IF (.NOT.IER) BULL_PARAMETER = 'SYS$LOGIN:BULL.CUSTOM' CALL DISABLE_PRIVS OPEN(UNIT=3,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & STATUS='OLD',SHARED,IOSTAT=IER1,RECL=INPUT_LENGTH) OPEN(UNIT=4,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & DISPOSE='DELETE',CARRIAGECONTROL='LIST',STATUS='NEW', & SHARED,IOSTAT=IER,RECL=INPUT_LENGTH) CALL ENABLE_PRIVS IF (IER.NE.0) THEN WRITE(6,'('' ERROR: Error in opening custom file.'')') RETURN END IF LENP = LEN(PARAM) IER = 0 DO WHILE (IER.EQ.0) READ (3,'(Q,A)',IOSTAT=IER) ILEN,INPUT IF (IER.EQ.0.AND.PARAM(:LENP).NE.INPUT(2:LENP+1)) THEN WRITE (4,'(A)',IOSTAT=IER) INPUT(:ILEN) END IF END DO IF (CLI$GET_VALUE('SET_PARAM2',INPUT,ILEN)) THEN WRITE (4,'(A)',IOSTAT=IER) ':'//PARAM(:LENP)//':'//INPUT(:ILEN) END IF IF (PARAM.EQ.'exclude_limit') & DECODE(ILEN,'(I)',INPUT(:ILEN)) EXCLUDE_LIMIT CLOSE (UNIT=4,DISPOSE='SAVE') CLOSE (UNIT=3,DISPOSE='DELETE') CALL LIB$RENAME_FILE(BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & BULL_PARAMETER(:TRIM(BULL_PARAMETER))//';1') CALL CHECK_CUSTOM RETURN END SUBROUTINE CHECK_CUSTOM IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM DATA BULL_USER_CUSTOM/.FALSE./ COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(INPUT_LENGTH) OLD_BUFFER COMMON /SCRATCH_INCLUDE/ SCRATCH_B1,NINCLUDE,EXC_CHANGED COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /FILE_DIRECTORY/ FILE_DIRECTORY CHARACTER*64 FILE_DIRECTORY COMMON /EXCLUDE_LIMIT/ EXCLUDE_LIMIT DATA EXCLUDE_LIMIT /0/ DIMENSION BTIM(2) FILE_DIRECTORY = ' ' IF (.NOT.BTEST(BULL_USER_CUSTOM,4)) THEN BULL_USER_CUSTOM = .FALSE. ELSE BULL_USER_CUSTOM = .FALSE. BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,4) END IF IER = SYS_TRNLNM('BULL_USER_CUSTOM',BULL_PARAMETER) IF (.NOT.IER) BULL_PARAMETER = 'SYS$LOGIN:BULL.CUSTOM' OPEN(UNIT=17,FILE=BULL_PARAMETER(:TRIM(BULL_PARAMETER)), & STATUS='OLD',SHARED,IOSTAT=IER,RECL=INPUT_LENGTH) IF (IER.NE.0) RETURN IF (SCRATCH_B1.NE.0) THEN ! Is queue empty? SCRATCH_B = SCRATCH_B1 ! No, set queue pointer to head ELSE ! Else if queue is empty CALL INIT_QUEUE(SCRATCH_B,OLD_BUFFER) SCRATCH_B1 = SCRATCH_B ! Init header pointer END IF NINCLUDE = 0 OLD_FORMAT = .FALSE. DO WHILE (IER.EQ.0) READ (17,'(Q,A)',IOSTAT=IER) OLEN,OLD_BUFFER IF (IER.EQ.0.AND.FOLDER_NAME(:TRIM(FOLDER_NAME))//':'.EQ. & OLD_BUFFER(:MIN(TRIM(FOLDER_NAME)+1,OLEN))) THEN BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,1) CALL LOWERCASE(OLD_BUFFER) IF (INDEX(OLD_BUFFER(TRIM(FOLDER_NAME)+2:),'defaults') & .EQ.1) THEN IF (INDEX(OLD_BUFFER,':header').GT.0) & BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,2) IF (INDEX(OLD_BUFFER,':kill').GT.0) & BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,3) ELSE BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,1) CALL CHECK_EXCL(OLD_BUFFER,OLEN,EXC,BLIMIT,BDATE,IER1) OLD_FORMAT = OLD_FORMAT.OR.(.NOT.IER1) IF (COMPARE_DATE(OLD_BUFFER(BDATE:OLEN-1),' ').GT.-EXC & .OR.EXC.EQ.0) THEN CALL WRITE_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,OLD_BUFFER) NINCLUDE = NINCLUDE + 1 ELSE EXC_CHANGED = .TRUE. END IF END IF ELSE IF (IER.EQ.0.AND.OLD_BUFFER(:1).EQ.':') THEN IF (INDEX(OLD_BUFFER,':header').GT.0) & BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,2) IF (INDEX(OLD_BUFFER,':kill').GT.0) & BULL_USER_CUSTOM = IBSET(BULL_USER_CUSTOM,3) IF (INDEX(OLD_BUFFER,':file_directory').GT.0) & FILE_DIRECTORY = OLD_BUFFER(17:) IF (INDEX(OLD_BUFFER,':exclude_limit').GT.0) THEN DECODE(OLEN-15,'(I)',OLD_BUFFER(16:),IOSTAT=IER1) & EXCLUDE_LIMIT EXCLUDE_LIMIT = MIN(999,EXCLUDE_LIMIT) END IF END IF END DO CLOSE (UNIT=17) IF (OLD_FORMAT) CALL CHECK_EXCLUDES RETURN END LOGICAL FUNCTION INCLUDE_MSG(STRING,STRING1) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(INPUT_LENGTH) OLD_BUFFER COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM DATA BULL_USER_CUSTOM/.FALSE./ COMMON /SCRATCH_INCLUDE/ SCRATCH_B1,NINCLUDE,EXC_CHANGED CHARACTER*(*) STRING,STRING1 CHARACTER*12 EXFROM INCLUDE_MSG = .TRUE. IF (BTEST(BULL_USER_CUSTOM,4)) RETURN IF (.NOT.BTEST(BULL_USER_CUSTOM,1)) RETURN SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header FLEN = TRIM(FOLDER_NAME) INC = .FALSE. DO I=1,NINCLUDE OLD_SCRATCH_B = SCRATCH_B CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,OLD_BUFFER) OLEN = TRIM(OLD_BUFFER) IF (STREQ(FOLDER_NAME(:FLEN)//':', & OLD_BUFFER(:MIN(FLEN+1,OLEN)))) THEN IF (STREQ(OLD_BUFFER(FLEN+2:FLEN+8),'INCLUDE')) THEN IF (.NOT.INC) INCLUDE_MSG = .FALSE. INC = .TRUE. END IF CALL CHECK_EXCL(OLD_BUFFER,OLEN,EXC,BLIMIT,BDATE,IER1) MATCH = .FALSE. IF (STREQ(OLD_BUFFER(FLEN+10:FLEN+14),'FROM:')) THEN CALL GET_FROM(EXFROM,OLD_BUFFER(FLEN+15:), & TRIM(OLD_BUFFER(FLEN+15:))) LS = TRIM(STRING) IF ((TRIM(OLD_BUFFER)-FLEN-14.EQ.LS.AND. & STRING.EQ.OLD_BUFFER(FLEN+15:)).OR.STREQ(FROM,EXFROM)) & MATCH = .TRUE. ELSE IF (STREQ(OLD_BUFFER(FLEN+10:FLEN+17),'SUBJECT:').AND. & STRFIND(STRING1(:TRIM(STRING1)),OLD_BUFFER & (FLEN+18:BLIMIT))) THEN MATCH = .TRUE. END IF IF (MATCH.AND..NOT.INC) THEN IF (COMPARE_DATE(OLD_BUFFER(BDATE:OLEN-1),' ').GT.-EXC.OR. & EXC.EQ.0) THEN IF (OLD_BUFFER(BLIMIT+1:BLIMIT+1).EQ.':') EXC = -1 CALL ADD_EXCL(OLD_BUFFER,BLIMIT,EXC) CALL WRITE_QUEUE(%VAL(OLD_SCRATCH_B),OLD_SCRATCH_B, & OLD_BUFFER) EXC_CHANGED = .TRUE. INCLUDE_MSG = .FALSE. END IF RETURN END IF END IF END DO RETURN END FUNCTION STRFIND(STRING,STRING1) IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING,STRING1 L = LEN(STRING1) DO I=0,LEN(STRING)-L J = 1 DO WHILE (J.LE.L) DIFF = ABS(ICHAR(STRING(I+J:I+J))-ICHAR(STRING1(J:J))) IF (DIFF.NE.0.AND.DIFF.NE.32) THEN J = L + 1 ELSE IF (J.EQ.L) THEN STRFIND = .TRUE. RETURN ELSE J = J + 1 END IF END DO END DO STRFIND = .FALSE. RETURN END SUBROUTINE SHOW_EXCLUDE(TYPE) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(INPUT_LENGTH) OLD_BUFFER COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM DATA BULL_USER_CUSTOM/.FALSE./ COMMON /SCRATCH_INCLUDE/ SCRATCH_B1,NINCLUDE,EXC_CHANGED COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING LOGICAL PAGING IF (.NOT.BTEST(BULL_USER_CUSTOM,1)) THEN IF (TYPE.EQ.0) WRITE (6,'('' There are no excludes.'')') IF (TYPE.EQ.1) WRITE (6,'('' There are no includes.'')') RETURN END IF SCRATCH_B = SCRATCH_B1 ! Init queue pointer to header FLEN = TRIM(FOLDER_NAME) FOUND = .FALSE. L = 1 DO I=1,NINCLUDE CALL READ_QUEUE(%VAL(SCRATCH_B),SCRATCH_B,OLD_BUFFER) OLEN = TRIM(OLD_BUFFER) IF (STREQ(FOLDER_NAME(:FLEN)//':',OLD_BUFFER(:MIN(FLEN+1,OLEN))) & .AND.((TYPE.EQ.1.AND.STREQ(OLD_BUFFER(FLEN+2:FLEN+8), & 'INCLUDE')).OR.(TYPE.EQ.0.AND.STREQ( & OLD_BUFFER(FLEN+2:FLEN+8),'EXCLUDE')))) THEN IF (.NOT.FOUND) THEN IF (TYPE.EQ.0) WRITE (6,'(1X,A,$)') 'Excludes for ' IF (TYPE.EQ.1) WRITE (6,'(1X,A,$)') 'Includes for ' WRITE (6,'(A)') '+'//FOLDER_NAME(:FLEN)//':' FOUND = .TRUE. END IF CALL CHECK_EXCL(OLD_BUFFER,OLEN,EXC,BLIMIT,BDATE,IER1) IF (BLIMIT+5-FLEN.GT.PAGE_WIDTH.AND.L+2.GT.PAGE_LENGTH-1) THEN L = L + 2 ELSE IF (L.EQ.0) THEN WRITE (6,'(''+'',A,$)') OLD_BUFFER(FLEN+10: & MIN(BLIMIT,PAGE_WIDTH+FLEN+9)) ELSE WRITE (6,'(1X,A,$)') OLD_BUFFER(FLEN+10: & MIN(BLIMIT,PAGE_WIDTH+FLEN+9)) END IF IF (OLD_BUFFER(BDATE+1:BDATE+1).EQ.'-') & OLD_BUFFER(BDATE:) = ' '//OLD_BUFFER(BDATE:) OUTLEN = MIN(BLIMIT,PAGE_WIDTH+FLEN+9)-FLEN-9 IF (OUTLEN.GT.PAGE_WIDTH-16) THEN WRITE (6,'(1X,X,A,1X,I3)') & OLD_BUFFER(BDATE:INDEX(OLD_BUFFER & (BDATE:),':')+BDATE-2),EXC L = L + 2 ELSE WRITE (6,'(''+'',X,A,1X,I3)') & OLD_BUFFER(BDATE:INDEX(OLD_BUFFER & (BDATE:),':')+BDATE-2),EXC L = L + 1 END IF END IF IF (PAGING.AND.L.EQ.PAGE_LENGTH-1) THEN L = 0 ! Reinitialize screen counter CALL LIB$PUT_OUTPUT(' ') CALL GET_INPUT_NOECHO_PROMPT( & INPUT(:1),'Press key to continue ... ') IER = LIB$ERASE_PAGE(1,1) ! Erase display END IF END IF END DO IF (.NOT.FOUND) THEN IF (TYPE.EQ.0) WRITE (6,'(1X,A,$)') 'No excludes found for ' IF (TYPE.EQ.1) WRITE (6,'(1X,A,$)') 'No includes found for ' WRITE (6,'(A)') '+'//FOLDER_NAME(:FLEN)//':' END IF RETURN END SUBROUTINE SET_NEWNAME 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) CHARACTER*12 NEW,OLD IF (.NOT.SETPRV_PRIV()) THEN WRITE (6,'('' ERROR: No privs to set a new name.'')') RETURN END IF CALL CLI$GET_VALUE('OLDNAME',OLD,LENO) CALL CLI$GET_VALUE('NEWNAME',NEW,LENN) CALL OPEN_BULLUSER_SHARED TEMP_USER = USERNAME DO WHILE (REC_LOCK(IER)) READ (4,IOSTAT=IER,KEYEQ=OLD) USER_ENTRY END DO IF (IER.EQ.0) THEN USERNAME = NEW DO WHILE (REC_LOCK(IER)) READ (4,IOSTAT=IER,KEYEQ=NEW) END DO IF (IER.NE.0) THEN WRITE (4,IOSTAT=IER) USER_ENTRY ELSE REWRITE (4,IOSTAT=IER) USER_ENTRY END IF END IF USERNAME = TEMP_USER DO WHILE (REC_LOCK(IER1)) READ (4,IOSTAT=IER1,KEYEQ=USERNAME) USER_ENTRY END DO CALL CLOSE_BULLUSER IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Old name not found.'')') RETURN END IF CALL OPEN_BULLINF_SHARED DO WHILE (REC_LOCK(IER)) READ (9,KEY=OLD,IOSTAT=IER) OLD,LAST END DO DO WHILE (REC_LOCK(IER)) READ (9,KEY=NEW,IOSTAT=IER) END DO IF (IER.NE.0) THEN WRITE (9,IOSTAT=IER) NEW,LAST ELSE REWRITE (9,IOSTAT=IER) NEW,LAST END IF OLD(LENO:LENO) = CHAR(128.OR.ICHAR(OLD(LENO:LENO))) NEW(LENN:LENN) = CHAR(128.OR.ICHAR(NEW(LENN:LENN))) DO WHILE (REC_LOCK(IER)) READ (9,KEY=OLD,IOSTAT=IER) OLD,LAST END DO IF (IER.EQ.0) THEN DO WHILE (REC_LOCK(IER)) READ (9,KEY=NEW,IOSTAT=IER) END DO IF (IER.NE.0) THEN WRITE (9,IOSTAT=IER) NEW,LAST ELSE REWRITE (9,IOSTAT=IER) NEW,LAST END IF ELSE DO WHILE (REC_LOCK(IER)) READ (9,KEY=NEW,IOSTAT=IER) END DO IF (IER.EQ.0) DELETE (9) END IF OLD(LENO:LENO) = CHAR(127.AND.ICHAR(OLD(LENO:LENO))) NEW(LENN:LENN) = CHAR(127.AND.ICHAR(NEW(LENN:LENN))) OLD(LENO:LENO) = CHAR(128.OR.ICHAR(OLD(LENO:LENO))) IF (LENO.GT.1) THEN OLD(LENO-1:LENO-1) = CHAR(128.OR.ICHAR(OLD(LENO-1:LENO-1))) ELSE OLD(2:2) = CHAR(128.OR.ICHAR(OLD(2:2))) END IF NEW(LENN:LENN) = CHAR(128.OR.ICHAR(NEW(LENN:LENN))) IF (LENN.GT.1) THEN NEW(LENN-1:LENN-1) = CHAR(128.OR.ICHAR(NEW(LENN-1:LENN-1))) ELSE NEW(2:2) = CHAR(128.OR.ICHAR(NEW(2:2))) END IF DO WHILE (REC_LOCK(IER)) READ (9,KEY=OLD,IOSTAT=IER) OLD,LAST END DO IF (IER.EQ.0) THEN DO WHILE (REC_LOCK(IER)) READ (9,KEY=NEW,IOSTAT=IER) END DO IF (IER.NE.0) THEN WRITE (9,IOSTAT=IER) NEW,LAST ELSE REWRITE (9,IOSTAT=IER) NEW,LAST END IF ELSE DO WHILE (REC_LOCK(IER)) READ (9,KEY=NEW,IOSTAT=IER) END DO IF (IER.EQ.0) DELETE (9) END IF CALL CLOSE_BULLINF RETURN END SUBROUTINE CHECK_EXCL(BUFFER,L,EXC,BLIMIT,BDATE,IER) IMPLICIT INTEGER (A-Z) COMMON /EXCLUDE_LIMIT/ EXCLUDE_LIMIT CHARACTER*(*) BUFFER DIMENSION BTIM(2) BLIMIT = L BDATE = L+3 IER = BUFFER(L:L).EQ.':' IF (IER) THEN I = LAST_INDEX(BUFFER(:L-1),':') IF (I.GT.0) THEN J = LAST_INDEX(BUFFER(:I-1),':') IF (J.GT.0) THEN IF (J.LT.I-1) THEN DECODE(I-J-1,'(I)',BUFFER(J+1:I-1),IOSTAT=IER) EXC IER = IER.EQ.0 ELSE EXC = EXCLUDE_LIMIT END IF IF (IER) BLIMIT = J - 1 CALL STR$UPCASE(BUFFER(I+1:L-1),BUFFER(I+1:L-1)) IF (IER) IER = SYS_BINTIM(BUFFER(I+1:L-1),BTIM) BDATE = I + 1 END IF ELSE IER = .FALSE. END IF END IF IF (.NOT.IER.AND.STRFIND(BUFFER,':exclude:')) & CALL ADD_EXCL(BUFFER,L,-1) RETURN END SUBROUTINE ADD_EXCL(BUFFER,L,EXC) IMPLICIT INTEGER (A-Z) DIMENSION BTIM(2) CHARACTER*(*) BUFFER CHARACTER TODAY*24 IF (EXC.EQ.-1) THEN BUFFER = BUFFER(:L)//':' ELSE BUFFER = BUFFER(:L)//':' WRITE (BUFFER(L+2:),'(I3)') EXC IF (BUFFER(L+2:L+2).EQ. ' ') BUFFER(L+2:) = BUFFER(L+3:) IF (BUFFER(L+2:L+2).EQ. ' ') BUFFER(L+2:) = BUFFER(L+3:) END IF CALL SYS$ASCTIM(,TODAY,,) ! Get the present time IF (TODAY(1:1).EQ.' ') TODAY = TODAY(2:) BUFFER = BUFFER(:TRIM(BUFFER))//':'//TODAY(:INDEX(TODAY,' ')-1)//':' L = TRIM(BUFFER) RETURN END