C C BULLETIN6.FOR, Version 9/15/95 C Purpose: Contains subroutines for the BULLETIN utility program. C Environment: VAX/VMS C Programmer: Mark R. London C SUBROUTINE CLOSE_FILE C C SUBROUTINE CLOSE_FILE C C FUNCTION: To close out the bulletin files and enable CTRL-C & -Y C IMPLICIT INTEGER (A-Z) COMMON /BULLFIL/ BULLFIL DATA BULLFIL /0/ DATA LUN /0/ ENTRY CLOSE_BULLINF LUN = LUN + 1 ! Unit = 9 ENTRY CLOSE_SYSUAF LUN = LUN + 1 ! Unit = 8 ENTRY CLOSE_BULLNEWS ENTRY CLOSE_BULLFOLDER LUN = LUN + 3 ! Unit = 7 ENTRY CLOSE_BULLUSER LUN = LUN + 2 ! Unit = 4 ENTRY CLOSE_BULLDIR LUN = LUN + 1 ! Unit = 2 ENTRY CLOSE_BULLFIL LUN = LUN + 1 ! Unit = 1 CALL ENABLE_CTRL CLOSE (UNIT=LUN) IF (LUN.EQ.1.AND.BULLFIL.GT.0) BULLFIL = -BULLFIL LUN = 0 RETURN END SUBROUTINE CLOSE_FILE_DELETE IMPLICIT INTEGER (A-Z) COMMON /BULLFIL/ BULLFIL DATA LUN /0/ ENTRY CLOSE_BULLDIR_DELETE LUN = LUN + 1 ! Unit = 2 ENTRY CLOSE_BULLFIL_DELETE LUN = LUN + 1 ! Unit = 1 CALL ENABLE_CTRL CLOSE (UNIT=LUN,STATUS='DELETE') IF (LUN.EQ.1.AND.BULLFIL.GT.0) BULLFIL = -BULLFIL LUN = 0 RETURN END SUBROUTINE OPEN_FILE(UNIT) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE '($FORIOSDEF)' INCLUDE '($PRVDEF)' INCLUDE '($RMSDEF)' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /DIR_POSITION/ DIR_NUM COMMON /NEWS_OPEN/ NEWS_OPEN COMMON /BULLFIL/ BULLFIL COMMON /NEWSLIST/ NEWSLIST COMMON /DIRLIST/ DIRLIST COMMON /NEWSDIR_FILE/ BULLNEWSDIR_FILE CHARACTER*80 BULLNEWSDIR_FILE DATA LUN /0/ LUN = UNIT - 14 ! 14 gets added to LUN ENTRY OPEN_BULLNEWS LUN = LUN + 5 ! Unit = 14 ENTRY OPEN_BULLINF LUN = LUN + 1 ! Unit = 9 ENTRY OPEN_SYSUAF LUN = LUN + 1 ! Unit = 8 ENTRY OPEN_BULLFOLDER LUN = LUN + 3 ! Unit = 7 ENTRY OPEN_BULLUSER LUN = LUN + 2 ! Unit = 4 ENTRY OPEN_BULLDIR LUN = LUN + 1 ! Unit = 2 ENTRY OPEN_BULLFIL LUN = LUN + 1 ! Unit = 1 IER = 0 NTRIES = 0 CALL SET_PROTECTION CALL DISABLE_CTRL ! No breaks while file is open IF (LUN.EQ.2.AND.REMOTE_SET.EQ.4) THEN TRY = 0 CALL SET_BULLNEWSDIR_FILE(FOLDER_NUMBER) DO WHILE (FILE_LOCK(IER,IER1)) IF (DIRLIST) THEN OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, & BUFFERCOUNT=127, & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') ELSE OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') END IF IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.TRY.EQ.0) THEN BULLNEWSDIR_FILE = 'BULLNEWSDIR.DAT' CALL ADD_DIRECTORY(BULLNEWSDIR_FILE) TRY = 1 IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop ELSE IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN CALL SET_BULLNEWSDIR_FILE(FOLDER_NUMBER) OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='NEW',FORM='UNFORMATTED',SHARED, & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') ELSE IF (IER.EQ.FOR$IOS_INCRECLEN.OR. & IER.EQ.FOR$IOS_INVKEYSPE) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop LUN = 0 CALL CONVERT_BULLNEWSDIR NTRIES = 0 CALL SET_BULLNEWSDIR_FILE(FOLDER_NUMBER) ELSE IF (IER.EQ.FOR$IOS_OPEFAI) THEN CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.RMS$_DNF) THEN IER2 = LIB$CREATE_DIR(BULLNEWSDIR_FILE(: & INDEX(BULLNEWSDIR_FILE,']'))) IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) END IF END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO DIR_NUM = -1 ELSE IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') ELSE IF (IER.EQ.0) THEN INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN CLOSE (UNIT=2) IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLFILES NTRIES = 0 END IF ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLDIRS NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO DIR_NUM = -1 END IF IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN DO WHILE (FILE_LOCK(IER,IER1)) IF (REMOTE_SET.EQ.4) THEN IF (BULLFIL.NE.1) CALL SET_BULLFIL_NAME OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER,SHARED, & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, & FORM='UNFORMATTED') IF (IER.EQ.0) THEN DO WHILE (REC_LOCK(IER2)) READ (1'1,IOSTAT=IER2) NBLOCK END DO IF (IER2.NE.0) THEN NBLOCK = 1 WRITE (1'1,IOSTAT=IER2) NBLOCK END IF BULLFIL = 1 END IF ELSE OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='UNKNOWN',IOSTAT=IER, & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, & FORM='UNFORMATTED') END IF IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLFILE NTRIES = 0 ELSE IF (IER.EQ.FOR$IOS_OPEFAI) THEN CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.RMS$_DNF) THEN IER2 = LIB$CREATE_DIR( & FOLDER_FILE(:INDEX(FOLDER_FILE,']'))) IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) END IF END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO END IF IF (LUN.EQ.4) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='UNKNOWN', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) WRITE (4,FMT=USER_FMT) USER_HEADER_KEY,NEWEST_BTIM, & BBOARD_BTIM,PRV$M_OPER.OR.PRV$M_CMKRNL.OR. & PRV$M_SETPRV,(0,I=1,FLONG*4-1) CLOSE (UNIT=4) IDUMMY = FILE_LOCK(IER,IER1) ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_USERFILE NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO END IF IF (LUN.EQ.7) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=FOLDER_RECORD/4, & ORGANIZATION='INDEXED',IOSTAT=IER) IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN FOLDER1 = 'GENERAL' FOLDER1_OWNER = 'SYSTEM' FOLDER1_DESCRIP = 'Default general bulletin folder.' FOLDER1_BBOARD = 'NONE' FOLDER1_BBEXPIRE = 14 NBULL = 0 OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='UNKNOWN', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=FOLDER_RECORD, & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, & KEY=(1:44:CHARACTER,45:48:INTEGER,49:56:CHARACTER)) CALL SYS_BINTIM('5-NOV-1982 00:00:00.00', & NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(NEWS_F_NEWEST_BTIM,FOLDER1_CREATED_DATE) WRITE (7,FMT=FOLDER_FMT,IOSTAT=IER2) & FOLDER1,0,FOLDER1_CREATED_DATE,FOLDER1_OWNER,FOLDER1_DESCRIP & ,FOLDER1_BBOARD,FOLDER1_BBEXPIRE,USERB,GROUPB,ACCOUNTB & ,NBULL,F_NEWEST_BTIM,4,0,F_NEWEST_NOSYS_BTIM,0,0,0 ! 4 means system folder CLOSE (UNIT=7) IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_BULLFOLDER(BULLFOLDER_FILE) NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO IF (IER.EQ.0) NEWS_OPEN = .FALSE. END IF IF (LUN.EQ.14) THEN DO WHILE (FILE_LOCK(IER,IER1)) IF (NEWSLIST) THEN OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=NEWS_FOLDER_RECORD/4, & BUFFERCOUNT=127, & ORGANIZATION='INDEXED',IOSTAT=IER) ELSE OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=NEWS_FOLDER_RECORD/4, & ORGANIZATION='INDEXED',IOSTAT=IER) END IF IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='UNKNOWN', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=NEWS_FOLDER_RECORD, & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER2, & KEY=(1:44:CHARACTER,45:48:INTEGER,49:56:CHARACTER, & 57:64:CHARACTER:DESCENDING)) CLOSE (UNIT=7) IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop ELSE IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_BULLNEWS(BULLNEWS_FILE) NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.10) CALL TIMER_ERR(LUN) END DO IF (IER.EQ.0) NEWS_OPEN = .TRUE. END IF IF (LUN.EQ.9) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='UNKNOWN', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, & IOSTAT=IER,ORGANIZATION='INDEXED', & KEY=(1:12:CHARACTER)) IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_INFFILE NTRIES = 0 END IF NTRIES = 0 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO END IF IF (IER.NE.0) THEN WRITE (6,'( & '' Cannot open file in OPEN_FILE, unit = '',I)') LUN 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 CALL ENABLE_CTRL_EXIT ! Enable CTRL-Y & -C & EXIT END IF LUN = 0 CALL RESET_PROTECTION RETURN END SUBROUTINE TIMER_ERR(UNIT) IMPLICIT INTEGER (A-Z) CHARACTER*14 NAMES(6) DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', & 'BULLINF.DAT','BULLNEWS.DAT'/ INTEGER NAME(14) DATA NAME/2,1,0,3,0,0,4,0,5,0,0,0,0,6/ IF (TEST_BULLCP().NE.2) THEN ! If BULLCP process, don't log error WRITE(6,'('' ERROR: Unable to open file: '',A)') & NAMES(NAME(UNIT))(:TRIM(NAMES(NAME(UNIT)))) IF (UNIT.EQ.14) THEN WRITE (6,'('' Database conversion in progress. Try later.'')') ELSE WRITE (6,'('' Please try again later.'')') END IF END IF CALL ENABLE_CTRL_EXIT ! No breaks while file is open END SUBROUTINE OPEN_FILE_SHARED IMPLICIT INTEGER (A-Z) INCLUDE '($FORIOSDEF)' INCLUDE '($RMSDEF)' INCLUDE 'BULLFILES.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' COMMON /POINT/ BULL_POINT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /DIR_POSITION/ DIR_NUM COMMON /NEWS_OPEN/ NEWS_OPEN COMMON /BULLFIL/ BULLFIL EXTERNAL LNM_MODE_EXEC,ENABLE_CTRL_EXIT C C The following 2 files were used prior to V1.1. C CHARACTER*80 BULLDIR_FILE /'BULL_DIR:BULLDIR.DAT'/ CHARACTER*80 BULLETIN_FILE /'BULL_DIR:BULLETIN.DAT'/ COMMON /NEWSLIST/ NEWSLIST DATA NEWSLIST/0/ COMMON /DIRLIST/ DIRLIST DATA DIRLIST/0/ COMMON /NEWSDIR_FILE/ BULLNEWSDIR_FILE CHARACTER*80 BULLNEWSDIR_FILE CHARACTER*44 SAVE_FOLDER DATA SAVE_BLOCK/-1/ CHARACTER*14 NAMES(6) DATA NAMES/'directory','message','BULLUSER.DAT','BULLFOLDER.DAT', & 'BULLINF.DAT','BULLNEWS.DAT'/ INTEGER NAME(14) DATA NAME/2,1,0,3,0,0,4,0,5,0,0,0,0,6/ DATA LUN /0/ ENTRY OPEN_BULLNEWS_SHARED LUN = LUN + 5 ! Unit = 14 ENTRY OPEN_BULLINF_SHARED LUN = LUN + 1 ! Unit = 9 ENTRY OPEN_SYSUAF_SHARED LUN = LUN + 1 ! Unit = 8 ENTRY OPEN_BULLFOLDER_SHARED LUN = LUN + 3 ! Unit = 7 ENTRY OPEN_BULLUSER_SHARED LUN = LUN + 2 ! Unit = 4 ENTRY OPEN_BULLDIR_SHARED LUN = LUN + 1 ! Unit = 2 ENTRY OPEN_BULLFIL_SHARED LUN = LUN + 1 ! Unit = 1 IER = 0 NTRIES = 0 CALL DISABLE_CTRL IF (LUN.EQ.2.AND.REMOTE_SET.EQ.4) THEN CALL SET_BULLNEWSDIR_FILE(FOLDER_NUMBER) DO WHILE (FILE_LOCK(IER,IER1)) IF (DIRLIST) THEN OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, & BUFFERCOUNT=127, & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') ELSE OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') END IF IF (IER.EQ.FOR$IOS_INCRECLEN.OR. & IER.EQ.FOR$IOS_INVKEYSPE) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop LUN = 0 CALL CONVERT_BULLNEWSDIR LUN = 2 NTRIES = 0 CALL SET_BULLNEWSDIR_FILE(FOLDER_NUMBER) ELSE IF (IER.EQ.FOR$IOS_OPEFAI) THEN CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.RMS$_DNF) THEN IER1 = LIB$CREATE_DIR(BULLNEWSDIR_FILE(: & INDEX(BULLNEWSDIR_FILE,']'))) IF (IER1) IDUMMY = FILE_LOCK(IER,IER1) END IF END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL TIMER_ERR(LUN) END DO DIR_NUM = -1 ELSE IF (LUN.EQ.2.AND..NOT.REMOTE_SET) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,SHARED, & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.(FOLDER_NUMBER.EQ.0 & .OR.FOLDER.EQ.'GENERAL')) THEN IER2 = LIB$RENAME_FILE(BULLETIN_FILE,'GENERAL.BULLFIL') IER2 = LIB$RENAME_FILE(BULLDIR_FILE,'GENERAL.BULLDIR') IF (IER2) IDUMMY = FILE_LOCK(IER,IER1) ! Don't break out of loop ELSE IF (IER.EQ.0) THEN INQUIRE(UNIT=2,RECORDSIZE=ASK_SIZE) IF (ASK_SIZE.NE.DIR_RECORD_LENGTH/4) THEN CLOSE (UNIT=2) IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLFILES NTRIES = 0 END IF ELSE IF (IER.EQ.FOR$IOS_INCFILORG) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLDIRS NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT END DO DIR_NUM = -1 END IF IF (LUN.EQ.1.AND.REMOTE_SET.AND.(SAVE_BLOCK.NE.BLOCK.OR. & SAVE_FOLDER.NE.FOLDER)) THEN CALL REMOTE_READ_MESSAGE(BULL_POINT,IER) IF (IER.GT.0) THEN CALL ERROR_AND_EXIT ELSE SAVE_BLOCK = BLOCK SAVE_FOLDER = FOLDER CALL GET_REMOTE_MESSAGE(IER) IER = 0 END IF ELSE IF (LUN.EQ.1.AND..NOT.REMOTE_SET) THEN SAVE_BLOCK = -1 IF (REMOTE_SET.EQ.4.AND.BULLFIL.NE.2) CALL SET_BULLFIL_NAME DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='OLD', & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, & FORM='UNFORMATTED',IOSTAT=IER,SHARED,READONLY) IF (REMOTE_SET.EQ.4) THEN IF (IER.EQ.0) THEN DO WHILE (REC_LOCK(IER2)) READ (1'1,IOSTAT=IER2) NBLOCK END DO IF (IER2.NE.0) NBLOCK = 1 BULLFIL = 2 END IF END IF IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_BULLFILE NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT END DO END IF IF (LUN.EQ.4) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=7+FLONG*4, & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, & KEY=(1:12:CHARACTER)) IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_USERFILE NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT END DO END IF IF (LUN.EQ.7) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=7,FILE=BULLFOLDER_FILE,STATUS='OLD', & RECORDSIZE=FOLDER_RECORD/4, & ACCESS='KEYED',RECORDTYPE='FIXED', & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED) IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_BULLFOLDER(BULLFOLDER_FILE) NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT END DO IF (IER.EQ.0) NEWS_OPEN = .FALSE. END IF IF (LUN.EQ.14) THEN DO WHILE (FILE_LOCK(IER,IER1)) IF (NEWSLIST) THEN OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & BUFFERCOUNT=127, & RECORDSIZE=NEWS_FOLDER_RECORD/4, & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED) ELSE OPEN (UNIT=7,FILE=BULLNEWS_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=NEWS_FOLDER_RECORD/4, & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED) END IF IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_BULLNEWS(BULLNEWS_FILE) NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.10) CALL ENABLE_CTRL_EXIT END DO IF (IER.EQ.0) NEWS_OPEN = .TRUE. END IF IF (LUN.EQ.8) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=8,FILE='SYSUAF',DEFAULTFILE='SYS$SYSTEM:SYSUAF.DAT', & ACCESS='KEYED',FORM='UNFORMATTED',ORGANIZATION='INDEXED', & STATUS='OLD',READONLY,IOSTAT=IER,SHARED, & USEROPEN=LNM_MODE_EXEC) END DO END IF IF (LUN.EQ.9) THEN DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=FOLDER_MAX*2+3, & IOSTAT=IER,ORGANIZATION='INDEXED',SHARED, & KEY=(1:12:CHARACTER)) IF (IER.EQ.FOR$IOS_INCRECLEN) THEN IDUMMY = FILE_LOCK(IER,IER1) ! Avoid breaking out of DO loop CALL CONVERT_INFFILE NTRIES = 0 END IF NTRIES = NTRIES + 1 IF (NTRIES.GT.30) CALL ENABLE_CTRL_EXIT END DO END IF IF (IER.EQ.FOR$IOS_FILNOTFOU.AND.LUN.NE.8) THEN CALL OPEN_FILE(LUN) ELSE IF (IER.NE.0) THEN WRITE(6,'('' ERROR: Cannot open '',A)') & NAMES(NAME(LUN))(:TRIM(NAMES(NAME(LUN)))) IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) IF (LUN.EQ.2.AND.REMOTE_SET.EQ.4) WRITE(6,'(1X,A)') & BULLNEWSDIR_FILE(:TRIM(BULLNEWSDIR_FILE)) WRITE(6,'(1X,A)') FOLDER_FILE(:TRIM(FOLDER_FILE)) WRITE(6,'(1X,A)')USERNAME IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF CALL ENABLE_CTRL_EXIT END IF LUN = 0 RETURN END SUBROUTINE RESET_PROTECTION IMPLICIT INTEGER (A-Z) DATA PROT_LEVEL /0/ PROT_LEVEL = PROT_LEVEL - 1 IF (PROT_LEVEL.GT.0) RETURN CALL SYS$SETDFPROT(CUR_DEF_PROT,) ! Reset default protection RETURN ENTRY SET_PROTECTION PROT_LEVEL = PROT_LEVEL + 1 IF (PROT_LEVEL.GT.1) RETURN CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT) ! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP) RETURN END SUBROUTINE FOLDER_TO_NEWS IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' NEWS_FOLDER = FOLDER NEWS_FOLDER_NUMBER = FOLDER_NUMBER NEWS_FOLDER_DESCRIP = FOLDER_DESCRIP( & MIN(45,INDEX(FOLDER_DESCRIP,' ')):) NEWS_F_NBULL = F_NBULL NEWS_F_COUNT = F_COUNT NEWS_F_START = F_START NEWS_F_LAST = F_LAST NEWS_F_NEWEST_BTIM(1) = F_NEWEST_BTIM(1) NEWS_F_NEWEST_BTIM(2) = F_NEWEST_BTIM(2) NEWS_F_FLAG = FOLDER_FLAG NEWS_F_EXPIRE = FOLDER_BBEXPIRE NEWS_F_EXPIRE_LIMIT = F_EXPIRE_LIMIT RETURN ENTRY FOLDER1_TO_NEWS NEWS_FOLDER1 = FOLDER1 NEWS_FOLDER1_NUMBER = FOLDER1_NUMBER NEWS_FOLDER1_DESCRIP = FOLDER1_DESCRIP( & MIN(45,INDEX(FOLDER1_DESCRIP,' ')):) NEWS_F1_NBULL = F1_NBULL NEWS_F1_COUNT = F1_COUNT NEWS_F1_START = F1_START NEWS_F1_LAST = F1_LAST NEWS_F1_NEWEST_BTIM(1) = F1_NEWEST_BTIM(1) NEWS_F1_NEWEST_BTIM(2) = F1_NEWEST_BTIM(2) NEWS_F1_FLAG = FOLDER1_FLAG NEWS_F1_EXPIRE = FOLDER1_BBEXPIRE NEWS_F1_EXPIRE_LIMIT = F1_EXPIRE_LIMIT RETURN ENTRY NEWS_TO_FOLDER FOLDER = NEWS_FOLDER FOLDER_NUMBER = NEWS_FOLDER_NUMBER FOLDER_DESCRIP = NEWS_FOLDER(:MAX(1,TRIM(NEWS_FOLDER))) & //NEWS_FOLDER_DESCRIP FOLDER_BBOARD = '::' F_NBULL = NEWS_F_NBULL F_COUNT = NEWS_F_COUNT F_START = NEWS_F_START F_LAST = NEWS_F_LAST F_NEWEST_BTIM(1) = NEWS_F_NEWEST_BTIM(1) F_NEWEST_BTIM(2) = NEWS_F_NEWEST_BTIM(2) FOLDER_FLAG = NEWS_F_FLAG IF (BTEST(FOLDER_FLAG,8)) FOLDER_BBOARD = 'NONE' FOLDER_BBEXPIRE = NEWS_F_EXPIRE F_EXPIRE_LIMIT = NEWS_F_EXPIRE_LIMIT RETURN ENTRY NEWS_TO_FOLDER1 FOLDER1 = NEWS_FOLDER1 FOLDER1_NUMBER = NEWS_FOLDER1_NUMBER FOLDER1_DESCRIP = NEWS_FOLDER1(:MAX(1,TRIM(NEWS_FOLDER1))) & //NEWS_FOLDER1_DESCRIP FOLDER1_BBOARD = '::' F1_COUNT = NEWS_F1_COUNT F1_NBULL = NEWS_F1_NBULL F1_START = NEWS_F1_START F1_LAST = NEWS_F1_LAST F1_NEWEST_BTIM(1) = NEWS_F1_NEWEST_BTIM(1) F1_NEWEST_BTIM(2) = NEWS_F1_NEWEST_BTIM(2) FOLDER1_FLAG = NEWS_F1_FLAG IF (BTEST(FOLDER1_FLAG,8)) FOLDER1_BBOARD = 'NONE' FOLDER1_BBEXPIRE = NEWS_F1_EXPIRE F1_EXPIRE_LIMIT = NEWS_F1_EXPIRE_LIMIT RETURN END SUBROUTINE CONVERT_BULLNEWSDIR IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' INCLUDE '($FORIOSDEF)' COMMON /NEWSDIR_FILE/ BULLNEWSDIR_FILE CHARACTER*80 BULLNEWSDIR_FILE CHARACTER*180 TEMP CHARACTER BUFFER*12,DATETIME*24 WRITE (6,'('' Converting data files to new format. Please wait.'')') CALL SET_PROTECTION CALL OPEN_BULLNEWS OPEN (UNIT=2,FILE=BULLNEWSDIR_FILE, & STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=180/4, & ORGANIZATION='INDEXED',IOSTAT=IER, & BUFFERCOUNT=127,KEY=(13:20:CHARACTER, & 1:8:CHARACTER,9:20:CHARACTER,21:84:CHARACTER, & 85:96:CHARACTER),ACCESS='KEYED') IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. IER1 = LIB$CREATE_DIR( & FOLDER_FILE(:MINGT0(INDEX(FOLDER_FILE,'.]'), & INDEX(FOLDER_FILE,'.BULLNEWS')))//'BULLNEWSDIR]') IF (.NOT.IER1) GO TO 900 NEW_FOLDER_NUMBER = 0 DO WHILE (IER.EQ.0) READ (2,IOSTAT=IER) TEMP IF (GET_INTEGER(%REF(TEMP)).NE.NEW_FOLDER_NUMBER) THEN IF (NEW_FOLDER_NUMBER.NE.0) CLOSE (UNIT=9,DISPOSE='KEEP') NEW_FOLDER_NUMBER = GET_INTEGER(%REF(TEMP)) CALL SET_BULLNEWSDIR_FILE(NEW_FOLDER_NUMBER) OPEN (UNIT=9,FILE=BULLNEWSDIR_FILE, & STATUS='UNKNOWN',FORM='UNFORMATTED',SHARED, & RECORDTYPE='FIXED',RECORDSIZE=NEWSDIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', & BUFFERCOUNT=127, & KEY=(1:4:INTEGER,5:12:CHARACTER,13:20:CHARACTER, & 57:64:CHARACTER),ACCESS='KEYED') IF (IER.NE.0) GO TO 900 END IF NEWS_MSG_NUM = GET_INTEGER(%REF(TEMP(5:))) NEWS_MSG_BTIM_KEY = TEMP(13:) NEWS_EX_BTIM_KEY = TEMP(89:) NEWS_MSGID = TEMP(21:) CALL COPY2(MSG_BTIM,%REF(TEMP(97:))) CALL CONVERT_TO_GMT(MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,NEWS_POST_KEY) CALL LIB$MOVC3(76,%REF(TEMP(105:)),NEWS_BLOCK) WRITE (9,IOSTAT=IER1) NEWSDIR_ENTRY END DO CLOSE (UNIT=9,DISPOSE='KEEP') CLOSE (UNIT=2) CALL RESET_PROTECTION BULLNEWSDIR_FILE = 'BULLNEWSDIR.DAT' CALL ADD_DIRECTORY(BULLNEWSDIR_FILE) IER = LIB$RENAME_FILE(BULLNEWSDIR_FILE(:TRIM(BULLNEWSDIR_FILE)) & ,'BULLNEWSDIR.OLD') WRITE (6,'('' BULLNEWSDIR.DAT has been renamed to '', & '' BULLNEWSDIR.OLD and may now be deleted.'')') RETURN 900 CALL RESET_PROTECTION CALL CLOSE_BULLNEWS WRITE(6,'('' ERROR: Cannot convert BULLNEWSDIR.DAT'')') IF (IER.EQ.0) CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF CALL ENABLE_CTRL_EXIT END SUBROUTINE CONVERT_BULLDIRS IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' CHARACTER BUFFER*116 WRITE (6,'('' Converting data files to new format. Please wait.'')') CALL SET_PROTECTION OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',ACCESS='DIRECT', & ORGANIZATION='RELATIVE',DISPOSE='KEEP', & IOSTAT=IER) IF (IER.NE.0) GO TO 900 ! No BULLDIR file found. READ (2'1,IOSTAT=IER1) BUFFER(:115) CALL LIB$MOVC3(4,%REF(BUFFER(39:)),NBULL) OPEN (UNIT=9,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='NEW',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)+5 ) IF (IER.NE.0) THEN OPEN (UNIT=9,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='DELETE', & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') END IF IF (IER1.NE.0) GO TO 800 CALL SYS_BINTIM(BUFFER(:11)//' '//BUFFER(12:19),NEWEST_EXBTIM) CALL SYS_BINTIM(BUFFER(20:30)//' '//BUFFER(31:38),NEWEST_MSGBTIM) BULLDIR_HEADER(29:40) = BUFFER(39:) CALL SYS_BINTIM(BUFFER(51:61)//' '//BUFFER(62:69),SHUTDOWN_BTIM) BULLDIR_HEADER(49:52) = BUFFER(70:) IF (IER.EQ.0) WRITE (9,IOSTAT=IER) BULLDIR_HEADER ICOUNT = 2 DO WHILE (IER.EQ.0) READ (2'ICOUNT,IOSTAT=IER) BUFFER(:115) IF (IER.EQ.0) THEN MSG_NUM = ICOUNT - 1 DESCRIP = BUFFER(:) FROM = BUFFER(54:) BULLDIR_ENTRY(81:84) = BUFFER(85:) BULLDIR_ENTRY(93:100) = BUFFER(108:) CALL SYS_BINTIM(BUFFER(89:99)//' '//BUFFER(100:107),EX_BTIM) CALL SYS_BINTIM(BUFFER(66:76)//' '//BUFFER(77:84),MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE (9,IOSTAT=IER) BULLDIR_ENTRY ICOUNT = ICOUNT + 1 END IF END DO 800 CLOSE (UNIT=9,DISPOSE='KEEP') CLOSE (UNIT=2) 900 CALL RESET_PROTECTION RETURN END SUBROUTINE CONVERT_BULLFILES C C SUBROUTINE CONVERT_BULLFILES C C FUNCTION: Converts bulletin files to new format file. C Add expiration time to directory file, add extra byte to bulletin C file to show where each bulletin starts (for redunancy sake in C case crash occurs). C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' CHARACTER*81 BUFFER WRITE (6,'('' Converting data files to new format. Please wait.'')') OPEN (UNIT=9,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='OLD', & RECORDTYPE='FIXED',RECORDSIZE=107,ACCESS='DIRECT', & ORGANIZATION='RELATIVE',DISPOSE='KEEP',FORM='FORMATTED', & SHARED,READONLY,IOSTAT=IER) IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='OLD', & RECORDTYPE='FIXED',RECORDSIZE=80, & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? CALL SET_PROTECTION OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=81, & FORM='FORMATTED') OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='NEW',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER,DISPOSE='KEEP', & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') NEWEST_EXTIME = '00:00:00.00' READ (9'1,1000,IOSTAT=IER) & NEWEST_EXDATE,NEWEST_DATE,NEWEST_TIME(:8), & NBULL,NBLOCK,SHUTDOWN,SHUTDOWN_DATE,SHUTDOWN_TIME(:8) NEMPTY = 0 IF (IER.EQ.0) CALL WRITEDIR(0,IER1) EXTIME = '00:00:00.00' ICOUNT = 2 DO WHILE (IER.EQ.0) READ(9'ICOUNT,1010,IOSTAT=IER) & DESCRIP,FROM,DATE,TIME(:8),LENGTH,EXDATE,SYSTEM,BLOCK IF (IER.EQ.0) THEN READ(10,'(A)') BUFFER WRITE(1,'(A)') BUFFER(:80)//CHAR(1) DO I=2,LENGTH READ(10,'(A)') BUFFER WRITE(1,'(A)') BUFFER END DO CALL WRITEDIR(ICOUNT-1,IER1) ICOUNT = ICOUNT + 1 END IF END DO CLOSE (UNIT=9) CLOSE (UNIT=2) CLOSE (UNIT=10) CLOSE (UNIT=1) CALL RESET_PROTECTION RETURN 1000 FORMAT(A11,A11,A8,A4,A4,A4,A11,A8) 1010 FORMAT(A53,A12,A11,A8,A4,A11,A4,A4) END SUBROUTINE CONVERT_BULLFILE C C SUBROUTINE CONVERT_BULLFILE C C FUNCTION: Converts bulletin data file to new format file. C C NOTE: CONVERT_BULLFILES converts from 80 to 81 byte length. C This converts from 81 byte length to 128 compressed format. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' CHARACTER*80 BUFFER,NEW_FILE WRITE (6,'('' Converting data files to new format. Please wait.'')') CALL CLOSE_BULLDIR CALL SET_PROTECTION CALL OPEN_BULLFOLDER 100 READ (7,FMT=FOLDER_FMT,ERR=200) & FOLDER,FOLDER_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) & //FOLDER(:TRIM(FOLDER)) NEW_FILE = FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFILOLD' OPEN (UNIT=10,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL' & ,STATUS='OLD', & RECORDTYPE='FIXED',RECORDSIZE=81,ACCESS='DIRECT', & FORM='FORMATTED',IOSTAT=IER,SHARED,READONLY) IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL',STATUS='NEW',IOSTAT=IER, & ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32, & FORM='UNFORMATTED') IER = LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLFIL;-1',NEW_FILE) CALL OPEN_BULLDIR CALL READDIR(0,IER) IF (IER.EQ.1) THEN NBLOCK = 0 DO I=1,NBULL CALL READDIR(I,IER) NBLOCK = NBLOCK + 1 SBLOCK = NBLOCK DO J=BLOCK,LENGTH+BLOCK-1 READ(10'J,'(A)') BUFFER ILEN = TRIM(BUFFER) IF (ILEN.EQ.0) ILEN = 1 CALL STORE_BULL(ILEN,BUFFER,NBLOCK) END DO CALL FLUSH_BULL(NBLOCK) LENGTH = NBLOCK - SBLOCK + 1 BLOCK = SBLOCK CALL WRITEDIR(I,IER) END DO NEMPTY = 0 CALL WRITEDIR(0,IER) END IF CLOSE (UNIT=10) CLOSE (UNIT=1) CALL CLOSE_BULLDIR GOTO 100 200 CALL OPEN_BULLDIR_SHARED CALL RESET_PROTECTION RETURN END SUBROUTINE CONVERT_BULLFOLDER(FILENAME) C C SUBROUTINE CONVERT_BULLFOLDER C C FUNCTION: Converts bulletin folder file to new format. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' INCLUDE '($SSDEF)' INCLUDE '($FORIOSDEF)' CHARACTER*(*) FILENAME CHARACTER NEW_FILE*80,OLD_FOLDER*25 WRITE (6,'('' Converting '',A,'' to new format. Please wait.'')') & FILENAME(:TRIM(FILENAME)) CALL SET_PROTECTION EODIR = MAX(INDEX(FILENAME,':'),INDEX(FILENAME,']')) SUFFIX = INDEX(FILENAME(EODIR:),'.') + EODIR - 1 NEW_FILE = FILENAME(:SUFFIX)//'OLD' DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=7,FILE=FILENAME,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:25:CHARACTER,26:29:INTEGER)) END DO IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? INQUIRE(UNIT=7,RECORDSIZE=ASK_SIZE) OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=FOLDER_RECORD, & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:44:CHARACTER,45:48:INTEGER,49:56:CHARACTER), & DISPOSE='DELETE') IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? IF (ASK_SIZE.EQ.184.OR.ASK_SIZE.EQ.173) THEN F_NUMBER = 0 DO WHILE (IER.EQ.0) IF (ASK_SIZE.EQ.184) THEN READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,5A4)', & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) & OLD_FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET CALL COPY2(F_NEWEST_NOSYS_BTIM,F_NEWEST_BTIM) ELSE IF (ASK_SIZE.EQ.173) THEN READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8,7A4)', & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) & OLD_FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET & ,F_NEWEST_NOSYS_BTIM END IF IF (IER.EQ.0) THEN FOLDER = OLD_FOLDER CALL SYS_BINTIM('5-NOV-1982',NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(NEWS_F_NEWEST_BTIM,FOLDER_CREATED_DATE) IF (NEWS_FEED()) THEN CALL LIB$MOVC3(4,%REF(FOLDER_BBOARD(7:)),F_LAST) ELSE F_LAST = 0 END IF WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) & FOLDER,F_NUMBER,FOLDER_CREATED_DATE & ,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB & ,F_NBULL,F_NEWEST_BTIM,FOLDER_FLAG,FOLDER_SET & ,F_NEWEST_NOSYS_BTIM,0,0,F_LAST F_NUMBER = F_NUMBER + 1 END IF END DO ELSE F_NUMBER = 0 DO WHILE (IER.EQ.0) READ (7,FMT='(A25,A4,A12,A80,A12,3A4,A8)', & KEYGE=F_NUMBER,KEYID=1,IOSTAT=IER) & OLD_FOLDER,F_NUMBER,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB IF (IER.EQ.0) THEN FOLDER_FLAG = 0 IF (F_NUMBER.EQ.0) FOLDER_FLAG = IBSET(FOLDER_FLAG,2) FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) & //OLD_FOLDER(:TRIM(OLD_FOLDER)) CALL CHKACL & (FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLFIL',IER) IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN FOLDER_FLAG = IBSET(FOLDER_FLAG,0) END IF DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.BULLDIR',STATUS='OLD',FORM='UNFORMATTED', & RECORDTYPE='FIXED',RECORDSIZE=DIR_RECORD_LENGTH/4, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(9:12:INTEGER,1:8:CHARACTER),ACCESS='KEYED') IF (IER.EQ.FOR$IOS_INCFILORG) THEN IDUMMY = FILE_LOCK(IER,IER1) CALL CONVERT_BULLDIRS END IF END DO IF (IER.EQ.FOR$IOS_FILNOTFOU) THEN F_NEWEST_BTIM(1) = 0 F_NEWEST_BTIM(2) = 0 ELSE CALL READDIR(0,IER) IF (NEWEST_DATE.EQ.'5-NOV-1956 ') THEN IF (NBULL.GT.0) THEN CALL READDIR(NBULL,IER) NEWEST_DATE = DATE NEWEST_TIME = TIME CALL WRITEDIR(0,IER) END IF END IF CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,F_NEWEST_BTIM) CLOSE (UNIT=2) END IF FOLDER = OLD_FOLDER CALL SYS_BINTIM('5-NOV-1982',NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(NEWS_F_NEWEST_BTIM,FOLDER_CREATED_DATE) WRITE (19,FMT=FOLDER_FMT,IOSTAT=IER) & FOLDER,F_NUMBER,FOLDER_CREATED_DATE & ,FOLDER_OWNER,FOLDER_DESCRIP & ,FOLDER_BBOARD,FOLDER_BBEXPIRE,USERB,GROUPB,ACCOUNTB & ,NBULL,F_NEWEST_BTIM,FOLDER_FLAG,0,F_NEWEST_BTIM,0,0,0 F_NUMBER = F_NUMBER + 1 END IF END DO END IF CLOSE (UNIT=7) CLOSE (UNIT=19,STATUS='SAVE') IER = LIB$RENAME_FILE(NEW_FILE,FILENAME) IER = LIB$RENAME_FILE(BULLFOLDER_FILE//';-1',NEW_FILE) CALL RESET_PROTECTION IER = LIB$DELETE_FILE(BBOARD_DIRECTORY(:TRIM(BBOARD_DIRECTORY)) & //'BOARD.COM;*') ! BULLETIN$ is referenced in old file RETURN END SUBROUTINE CONVERT_BULLNEWS(FILENAME) C C SUBROUTINE CONVERT_BULLNEWS C C FUNCTION: Converts bulletin NEWS file to new format. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLFILES.INC' INCLUDE '($SSDEF)' INCLUDE '($FORIOSDEF)' CHARACTER*(*) FILENAME CHARACTER NEW_FILE*80,OLD_FOLDER*25,OLD_DESCRIP*55,TMP*2 WRITE (6,'('' Converting '',A,'' to new format. '' & ,''This will take a while.'')') FILENAME(:TRIM(FILENAME)) CALL SET_PROTECTION EODIR = MAX(INDEX(FILENAME,':'),INDEX(FILENAME,']')) SUFFIX = INDEX(FILENAME(EODIR:),'.') + EODIR - 1 NEW_FILE = FILENAME(:SUFFIX)//'OLD' DO WHILE (FILE_LOCK(IER,IER1)) OPEN (UNIT=7,FILE=FILENAME,STATUS='OLD', & RECORDTYPE='FIXED',ACCESS='KEYED', & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:25:CHARACTER,26:29:INTEGER)) END DO IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? OPEN (UNIT=19,FILE=NEW_FILE,STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED', & RECORDSIZE=NEWS_FOLDER_RECORD/4,INITIALSIZE=600, & ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:44:CHARACTER,45:48:INTEGER,49:56:CHARACTER, & 57:64:CHARACTER:DESCENDING),DISPOSE='DELETE') IF (IER.NE.0) CALL ERROR_AND_EXIT ! Error. Why? NEWS_FOLDER_NUMBER = 0 CALL SYS_BINTIM('5-NOV-1982',NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(NEWS_F_NEWEST_BTIM,NEWS_F_CREATED_DATE) CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(NEWS_F_NEWEST_BTIM,NEWS_F_EXPIRED_DATE) NEWS_F_LAST = 0 NEWS_F_FLAG = 0 NEWS_F_EXPIRE = 7 NEWS_F_FIRST = 0 NEWS_F_END = 0 NEWS_F_EXPIRE_LIMIT = 0 READ (7,KEY=1000,KEYID=1,IOSTAT=IER) INPUT(:108) DO WHILE (IER.EQ.0) OLD_FOLDER = INPUT(:25) CALL LIB$MOVC3(4,%REF(INPUT(26:)),NEWS_FOLDER_NUMBER) OLD_DESCRIP = INPUT(30:) CALL LIB$MOVC3(4,%REF(INPUT(87:)),NEWS_F_START) CALL LIB$MOVC3(4,%REF(INPUT(91:)),NEWS_F_COUNT) CALL LIB$MOVC3(4,%REF(INPUT(97:)),NEWS_F_NBULL) CALL LIB$MOVC3(8,%REF(INPUT(101:)),NEWS_F_NEWEST_BTIM) LMOVE = INDEX(OLD_DESCRIP,' ')-1 IF (LMOVE.LE.0) THEN NEWS_FOLDER = OLD_FOLDER NEWS_FOLDER_DESCRIP = OLD_DESCRIP ELSE NEWS_FOLDER = OLD_FOLDER//OLD_DESCRIP(:MIN(19,LMOVE)) NEWS_FOLDER_DESCRIP = OLD_DESCRIP(MIN(20,LMOVE+1):) END IF WRITE (19,IOSTAT=IER) NEWS_FOLDER_COM READ (7,IOSTAT=IER) INPUT(:108) END DO CLOSE (UNIT=7) CLOSE (UNIT=19,STATUS='SAVE') IER = LIB$RENAME_FILE(NEW_FILE,FILENAME) IER = LIB$RENAME_FILE(BULLNEWS_FILE//';-1',NEW_FILE) CALL RESET_PROTECTION RETURN END SUBROUTINE CONVERT_USERFILE C C SUBROUTINE CONVERT_USERFILE C C FUNCTION: Converts user file to new format which has 8 bytes added. C IMPLICIT INTEGER (A-Z) INCLUDE '($PRVDEF)' INCLUDE 'BULLFILES.INC' INCLUDE 'BULLUSER.INC' CHARACTER BUFFER*74,NEW_FILE*80 CHARACTER*12 LOGIN_DATE,READ_DATE CHARACTER*8 LOGIN_TIME,READ_TIME WRITE (6,'('' Converting data files to new format. Please wait.'')') EODIR = MAX(INDEX(BULLUSER_FILE,':'),INDEX(BULLUSER_FILE,']')) SUFFIX = INDEX(BULLUSER_FILE(EODIR:),'.') + EODIR - 1 NEW_FILE = BULLUSER_FILE(:SUFFIX)//'OLD' IER = LIB$RENAME_FILE(BULLUSER_FILE,NEW_FILE) OPEN (UNIT=9,FILE=NEW_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) INQUIRE (UNIT=9,RECORDSIZE=RECL) IF ((RECL-28)/16.GT.FLONG) THEN WRITE (6,'('' ERROR: Old data files have more folders'', & '' than was specified with BULLUSER.INC.'')') WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') IER = LIB$RENAME_FILE(NEW_FILE,BULLUSER_FILE) IF (USERNAME.EQ.'DECNET') THEN CALL SYS$DELPRC(,) ELSE CALL ENABLE_CTRL CALL SYS$CANEXH() CALL EXIT END IF END IF IF (IER.EQ.0) THEN CALL SET_PROTECTION OPEN (UNIT=4,FILE=BULLUSER_FILE,STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=28+FLONG*16, & FORM='FORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) END IF IF (IER.NE.0) THEN WRITE (6,'('' Cannot convert user file.'')') IF (IER1.EQ.0) CALL ERRSNS(IDUMMY,IER1) CALL SYS_GETMSG(IER1) CALL RESET_PROTECTION CALL ENABLE_CTRL_EXIT END IF DO I=1,FLONG NEW_FLAG(I) = 'FFFFFFFF'X NOTIFY_FLAG(I) = 0 BRIEF_FLAG(I) = 0 SET_FLAG(I) = 0 END DO IF (RECL.EQ.42.OR.RECL.EQ.50.OR.RECL.EQ.58.OR.RECL.EQ.66.OR. & RECL.EQ.74) THEN ! Old format IF (RECL.LE.58) RECL = 50 IER = 0 DO WHILE (IER.EQ.0) READ (9,'(A)',IOSTAT=IER) BUFFER IF (IER.EQ.0) THEN TEMP_USER = BUFFER(:12) LOGIN_DATE = BUFFER(13:23) LOGIN_TIME = BUFFER(24:31) READ_DATE = BUFFER(32:42) READ_TIME = BUFFER(43:50) IF (RECL.EQ.58) & CALL LIB$MOVC3(8,%REF(BUFFER(51:)),SET_FLAG(1)) IF (RECL.EQ.66) & CALL LIB$MOVC3(8,%REF(BUFFER(59:)),NEW_FLAG(1)) IF (RECL.EQ.74) & CALL LIB$MOVC3(8,%REF(BUFFER(67:)),NOTIFY_FLAG(1)) CALL SYS_BINTIM(LOGIN_DATE//' '//LOGIN_TIME,LOGIN_BTIM) CALL SYS_BINTIM(READ_DATE//' '//READ_TIME,READ_BTIM) WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG END IF END DO IF (RECL.LT.66) THEN READ (4,KEY=USER_HEADER_KEY,FMT=USER_FMT) TEMP_USER, & LOGIN_BTIM, & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG NEW_FLAG(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRV WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG END IF ELSE ! Folder maxmimum increase OFLONG = (RECL - 28) / 16 ! Old #longwords/flag DO WHILE (IER.EQ.0) READ (9,FMT='(A12,<4+OFLONG*4>A4)',IOSTAT=IER) & TEMP_USER,LOGIN_BTIM,READ_BTIM, & (NEW_FLAG(I),I=1,OFLONG),(SET_FLAG(I),I=1,OFLONG), & (BRIEF_FLAG(I),I=1,OFLONG),(NOTIFY_FLAG(I),I=1,OFLONG) IF (IER.EQ.0) THEN WRITE (4,FMT=USER_FMT) TEMP_USER,LOGIN_BTIM, & READ_BTIM,NEW_FLAG,SET_FLAG,BRIEF_FLAG,NOTIFY_FLAG END IF END DO END IF IER = 0 CLOSE (UNIT=9) CLOSE (UNIT=4) CALL RESET_PROTECTION RETURN END SUBROUTINE READDIR(BULLETIN_NUM,ICOUNT) C C SUBROUTINE READDIR C C FUNCTION: Finds the entry for the specified bulletin in the C directory file and returns the information for that entry. C C INPUTS: C BULLETIN_NUM - Bulletin number. Starts with 1. C If 0, gives header info, i.e number of bulls, C number of blocks in bulletin file, etc. C OUTPUTS: C ICOUNT - The last record read by this routine. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /PROMPT/ COMMAND_PROMPT CHARACTER*40 COMMAND_PROMPT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /DIR_POSITION/ DIR_NUM COMMON /NEXT/ NEXT COMMON /KEEPLOCK/ KEEPLOCK DATA KEEPLOCK/.FALSE./ COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD COMMON /BULLFIL/ BULLFIL COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM CHARACTER*4 CFOLDER_NUMBER ICOUNT = BULLETIN_NUM IF (ICOUNT.EQ.0) THEN IF (.NOT.REMOTE_SET) THEN DO WHILE (REC_LOCK(IER)) IF (REMOTE_SET.EQ.4) THEN IER = 0 ELSE READ (2,KEYID=0,KEY=0,IOSTAT=IER) BULLDIR_HEADER END IF END DO IF (IER.EQ.0) THEN CALL CONVERT_HEADER_FROMBIN IF (REMOTE_SET.EQ.4) THEN DIR_NUM = -1 ELSE DIR_NUM = 0 END IF END IF ELSE CALL REMOTE_GET_HEADER(BULLETIN_NUM,ICOUNT,IER) RETURN END IF IF (IER.EQ.0.AND..NOT.REMOTE_SET.EQ.4) THEN IF (NBULL.LT.0) THEN ! This indicates bulletin deletion ! was incomplete. CALL CLOSE_BULLDIR CALL OPEN_BULLDIR CALL CLEANUP_DIRFILE(1) CALL UPDATE_FOLDER END IF IF (NEMPTY.EQ.' '.AND. & FOLDER_BBOARD(:2).NE.'::') NEMPTY = 0 C C Check to see if cleanup of empty file space is necessary, which is C defined here as being 50 blocks (200 128byte records). Also check C to see if cleanup was in progress but didn't properly finish. C IF (NEMPTY.GT.200.AND.TEST_BULLCP().EQ.0) THEN WRITE (CFOLDER_NUMBER,'(I4)') FOLDER_NUMBER IER1 = LIB$SPAWN('$'//COMMAND_PROMPT(:INDEX( & COMMAND_PROMPT,'>')-1)//'/CLEANUP='//CFOLDER_NUMBER, & 'NL:','NL:',1,'BULL_CLEANUP') ELSE IF (NEMPTY.EQ.-1) THEN CALL CLEANUP_BULLFILE END IF END IF ELSE IF (.NOT.REMOTE_SET) THEN DO WHILE (REC_LOCK(IER)) IF (REMOTE_SET.EQ.4) THEN IF (NEXT) THEN IF (DIR_NUM.EQ.ICOUNT-1) THEN READ(2,IOSTAT=IER) NEWSDIR_ENTRY ELSE READ(2,KEYGE=ICOUNT & ,KEYID=0,IOSTAT=IER) NEWSDIR_ENTRY END IF ELSE IF (ICOUNT.LT.F_START) ICOUNT = F_START IF (ICOUNT.GT.F_NBULL) ICOUNT = F_NBULL IF (DIR_NUM.EQ.ICOUNT-1) THEN READ(2,IOSTAT=IER) NEWSDIR_ENTRY ELSE READ(2,KEY=ICOUNT & ,KEYID=0,IOSTAT=IER) NEWSDIR_ENTRY IF (IER.NE.0.AND.ICOUNT.EQ.F_START) THEN READ(2,KEYGT=ICOUNT & ,KEYID=0,IOSTAT=IER) NEWSDIR_ENTRY IF (IER.EQ.0) ICOUNT = NEWS_MSG_NUM END IF END IF IF (INCMD(:4).EQ.'BACK') THEN DO WHILE (IER.NE.0.AND.ICOUNT.GT.F_START) ICOUNT = ICOUNT - 1 READ(2,KEY=ICOUNT & ,KEYID=0,IOSTAT=IER) NEWSDIR_ENTRY END DO END IF END IF IF (IER.EQ.0) THEN MSG_NUM = NEWS_MSG_NUM IF (MSG_NUM.GT.F_NBULL) THEN IER = 36 UNLOCK 2 ELSE IF (ICOUNT.LE.F_START.AND. & MSG_NUM.GT.F_START) THEN INQUIRE (UNIT=7,OPENED=IER1) IF (.NOT.IER1) CALL OPEN_BULLNEWS_SHARED IDUMMY = REC_LOCK(IER) CALL READ_FOLDER_FILE_KEYNAME & (FOLDER,IER2) F_START = MSG_NUM CALL REWRITE_FOLDER_FILE(IER2) IF (.NOT.IER1) CALL CLOSE_BULLNEWS IDUMMY = REC_LOCK(IER) END IF IF (IER.EQ.0.AND.MSG_NUM.NE.BULLETIN_NUM) THEN ICOUNT = MSG_NUM BULLETIN_NUM = ICOUNT END IF END IF ELSE IF (DIR_NUM.EQ.ICOUNT-1) THEN READ(2,IOSTAT=IER) BULLDIR_ENTRY IF (IER.EQ.0.AND.BLOCK.EQ.0) THEN REWRITE (2) BULLDIR_ENTRY(:65)//' '// & BULLDIR_ENTRY(66:97) READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) & BULLDIR_ENTRY END IF IF (MSG_NUM.NE.ICOUNT) THEN IER = 36 UNLOCK 2 END IF ELSE READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) & BULLDIR_ENTRY IF (IER.EQ.0.AND.BLOCK.EQ.0) THEN REWRITE (2) BULLDIR_ENTRY(:65)//' '// & BULLDIR_ENTRY(66:97) READ(2,KEYID=0,KEY=ICOUNT,IOSTAT=IER) & BULLDIR_ENTRY END IF END IF END IF END DO IF (IER.EQ.0) THEN CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) CALL CONVERT_ENTRY_FROMBIN DIR_NUM = MSG_NUM IF (REMOTE_SET.EQ.4.AND.BULLFIL.GT.0) CALL SET_BULLFIL ELSE DIR_NUM = -1 END IF ELSE CALL REMOTE_GET_HEADER(BULLETIN_NUM,ICOUNT,IER) END IF END IF IF (IER.EQ.0) THEN IF (.NOT.REMOTE_SET) THEN ICOUNT = ICOUNT + 1 IF (.NOT.KEEPLOCK) UNLOCK 2 END IF IF (ICOUNT.GT.1.AND.BTEST(BULL_USER_CUSTOM,1)) THEN IF (BTEST(BULL_USER_CUSTOM,3)) THEN IF (.NOT.INCLUDE_MSG(FROM,DESCRIP)) ICOUNT = ICOUNT - 1 END IF END IF END IF RETURN END INTEGER FUNCTION GET_INTEGER(NUM) IMPLICIT INTEGER (A-Z) CHARACTER*4 CTEMP,INTEGER_KEY CTEMP = INTEGER_KEY(NUM) CALL LIB$MOVC3(4,%REF(CTEMP),GET_INTEGER) RETURN END CHARACTER*4 FUNCTION INTEGER_KEY(NUM) IMPLICIT INTEGER (A-Z) INTEGER TEMP CHARACTER*4 CTEMP EQUIVALENCE (CTEMP,TEMP) TEMP = NUM DO I=4,1,-1 INTEGER_KEY(I:I) = CTEMP(5-I:5-I) END DO RETURN END SUBROUTINE READDIR_KEYGE(IER) C C SUBROUTINE READDIR_KEYGE C C FUNCTION: Finds the entry for the specified bulletin in the C directory file corresponding to or later than the date specified. C C INPUTS: C MSG_KEY - Message key (passed via BULLDIR.INC common block). C OUTPUTS: C IER - If 0, no entry found. Else contains message number. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /DIR_POSITION/ DIR_NUM COMMON /KEYID/ NEWS_KEYID DATA NEWS_KEYID/1/ COMMON /KEEPLOCK/ KEEPLOCK COMMON /BULLFIL/ BULLFIL COMMON /BULL_USER_CUSTOM/ BULL_USER_CUSTOM 10 IF (.NOT.REMOTE_SET) THEN DO WHILE (REC_LOCK(IER)) IF (REMOTE_SET.EQ.4) THEN IF (NEWS_KEYID.NE.2.OR.MSG_NUM.EQ.0) THEN READ(2,KEYGT=MSG_KEY & ,KEYID=NEWS_KEYID,IOSTAT=IER) NEWSDIR_ENTRY ELSE READ(2,IOSTAT=IER) NEWSDIR_ENTRY END IF IF (IER.EQ.0) THEN MSG_NUM = NEWS_MSG_NUM IF (MSG_NUM.GT.F_NBULL) THEN IF (NEWS_KEYID.EQ.2.AND.MSG_NUM.NE.0) THEN IF (MSG_NUM.GT.NEWS_F_END) THEN IDUMMY = REC_LOCK(IER) END IF ELSE IER = 36 UNLOCK 2 END IF END IF END IF ELSE READ(2,KEYID=1,KEYGT=MSG_KEY,IOSTAT=IER) & BULLDIR_ENTRY IF (IER.EQ.0.AND.BLOCK.EQ.0) THEN REWRITE (2) BULLDIR_ENTRY(:65)//' '// & BULLDIR_ENTRY(66:97) READ(2,KEYID=0,KEY=MSG_NUM,IOSTAT=IER) & BULLDIR_ENTRY END IF END IF END DO IF (IER.EQ.0) THEN IER = MSG_NUM CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) CALL CONVERT_ENTRY_FROMBIN DIR_NUM = MSG_NUM IF (.NOT.KEEPLOCK) UNLOCK 2 IF (REMOTE_SET.EQ.4.AND.BULLFIL.GT.0) CALL SET_BULLFIL ELSE IER = 0 DIR_NUM = -1 END IF ELSE CALL REMOTE_GET_HEADER(DUMMY,-1,IER) END IF IF (IER.GT.0.AND.BTEST(BULL_USER_CUSTOM,1)) THEN IF (BTEST(BULL_USER_CUSTOM,3)) THEN IF (.NOT.INCLUDE_MSG(FROM,DESCRIP)) GO TO 10 END IF END IF RETURN END SUBROUTINE CONVERT_HEADER_FROMBIN IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER*24 DATETIME IF (REMOTE_SET.EQ.4) THEN CALL COPY2(NEWEST_MSGBTIM,NEWS_F_NEWEST_BTIM) CALL GET_MSGKEY(%REF(NEWS_F_EXPIRED_DATE),%DESCR(NEWEST_EXBTIM)) NBULL = F_NBULL NEMPTY = 0 END IF CALL SYS$ASCTIM(,DATETIME,NEWEST_EXBTIM,) NEWEST_EXDATE = DATETIME(:11) NEWEST_EXTIME = DATETIME(13:23) CALL SYS$ASCTIM(,DATETIME,NEWEST_MSGBTIM,) NEWEST_DATE = DATETIME(:11) NEWEST_TIME = DATETIME(13:23) CALL SYS$ASCTIM(,DATETIME,SHUTDOWN_BTIM,) SHUTDOWN_DATE = DATETIME(:11) SHUTDOWN_TIME = DATETIME(13:23) RETURN END SUBROUTINE CONVERT_ENTRY_FROMBIN IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /POST/ POSTTIME CHARACTER*24 DATETIME IF (REMOTE_SET.EQ.4) THEN CALL GET_MSGKEY(%REF(NEWS_MSG_BTIM_KEY),%DESCR(MSG_BTIM)) CALL GET_MSGKEY(%REF(NEWS_EX_BTIM_KEY),%DESCR(EX_BTIM)) IF (POSTTIME) THEN CALL GET_MSGKEY(%REF(NEWS_POST_KEY),%DESCR(MSG_BTIM)) CALL CONVERT_FROM_GMT(MSG_BTIM) ! Assume stored is GMT END IF DESCRIP = NEWS_DESCRIP FROM = NEWS_FROM BLOCK = NEWS_BLOCK LENGTH = NEWS_LENGTH SYSTEM = 0 END IF ENTRY CONVERT_ENTRY_FROMBIN_FOLDER CALL SYS$ASCTIM(,DATETIME,EX_BTIM,) EXDATE = DATETIME(:11) EXTIME = DATETIME(13:23) CALL SYS$ASCTIM(,DATETIME,MSG_BTIM,) DATE = DATETIME(:11) TIME = DATETIME(13:23) RETURN END SUBROUTINE WRITEDIR(BULLETIN_NUM,IER) C C SUBROUTINE WRITEDIR C C FUNCTION: Writes the entry for the specified bulletin in the C directory file. C C INPUTS: C BULLETIN_NUM - Bulletin number. Starts with 1. C If 0, write the header of the directory file. C OUTPUTS: C IER - Error status from WRITE. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /DIR_POSITION/ DIR_NUM CONV = .TRUE. GO TO 10 ENTRY WRITEDIR_NOCONV(BULLETIN_NUM,IER) CONV = .FALSE. 10 IF (BULLETIN_NUM.EQ.0) THEN IF (CONV) CALL CONVERT_HEADER_TOBIN IF (REMOTE_SET) THEN WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,0,BULLDIR_HEADER ELSE IER = -1 IF (DIR_NUM.EQ.0) THEN IF (REMOTE_SET.EQ.4) THEN IER = 0 ELSE REWRITE (2,IOSTAT=IER) BULLDIR_HEADER END IF END IF IF (IER.NE.0) THEN IF (REMOTE_SET.EQ.4) THEN IER = 0 ELSE READ (2,KEYID=0,KEY=0,IOSTAT=IER) IF (IER.EQ.0) THEN REWRITE (2,IOSTAT=IER) BULLDIR_HEADER END IF END IF END IF IF (IER.NE.0) THEN IF (REMOTE_SET.NE.4) THEN WRITE (2,IOSTAT=IER) BULLDIR_HEADER END IF END IF END IF ELSE MSG_NUM = BULLETIN_NUM IF (CONV) CALL CONVERT_ENTRY_TOBIN IF (REMOTE_SET) THEN WRITE(REMOTE_UNIT,'(3A)',IOSTAT=IER)9,BULLETIN_NUM, & BULLDIR_ENTRY ELSE IER = -1 IF (DIR_NUM.EQ.MSG_NUM) THEN IF (REMOTE_SET.EQ.4) THEN REWRITE (2,IOSTAT=IER) NEWSDIR_ENTRY ELSE REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY END IF END IF IF (IER.NE.0) THEN IF (REMOTE_SET.EQ.4) THEN IF (BULLETIN_NUM.NE.NEWS_F_END+1) THEN DO WHILE (REC_LOCK(IER)) READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) END DO END IF ELSE READ (2,KEYID=0,KEY=BULLETIN_NUM,IOSTAT=IER) END IF IF (REMOTE_SET.EQ.4.AND. & BULLETIN_NUM.EQ.NEWS_F_END+1) THEN CALL SPECIAL_NEWSDIR_ENTRY(IER) ELSE IF (IER.EQ.0) THEN IF (REMOTE_SET.EQ.4) THEN REWRITE (2,IOSTAT=IER) NEWSDIR_ENTRY ELSE REWRITE (2,IOSTAT=IER) BULLDIR_ENTRY END IF ELSE IF (REMOTE_SET.EQ.4) THEN WRITE (2,IOSTAT=IER) NEWSDIR_ENTRY ELSE WRITE (2,IOSTAT=IER) BULLDIR_ENTRY END IF END IF END IF END IF END IF IF (REMOTE_SET.AND.IER.GT.0) CALL ERROR_AND_EXIT DIR_NUM = -1 RETURN END SUBROUTINE SPECIAL_NEWSDIR_ENTRY(IER) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE '($RMSDEF)' CHARACTER*140 TEMP DIMENSION BTIM(2) READ (2,KEYID=3,KEY=NEWS_POST_KEY,IOSTAT=IER) TEMP DO WHILE (IER.EQ.0.AND.NEWS_POST_KEY.EQ.TEMP(57:64)) IF (NEWS_MSGID.EQ.TEMP(21:56)) THEN IER = 2 RETURN END IF READ (2,IOSTAT=IER) TEMP END DO 10 IER1 = 0 DO WHILE (REC_LOCK(IER1)) READ (2,KEYID=0,KEYGT=NEWS_F_END, & IOSTAT=IER1) INPUT(:NEWSDIR_RECORD_LENGTH) END DO DO WHILE (IER1.EQ.0) CALL LIB$MOVC3(4,%REF(INPUT),FNUM) CALL GET_MSGKEY(%REF(INPUT(13:)),%DESCR(BTIM)) IF (COMPARE_BTIM(BTIM,NEWEST_EXBTIM).LT.0.AND. & .NOT.BTEST(FOLDER_FLAG,13)) THEN CALL COPY2(NEWEST_EXBTIM,BTIM) END IF F_COUNT = F_COUNT + 1 CALL LIB$MOVC3(4,%REF(INPUT),NEWS_F_END) DO WHILE (REC_LOCK(IER1)) READ (2,IOSTAT=IER1) INPUT(:NEWSDIR_RECORD_LENGTH) END DO END DO IF (MSG_NUM.NE.NEWS_F_END+1) THEN MSG_NUM = NEWS_F_END + 1 CALL CONVERT_ENTRY_TOBIN END IF WRITE (2,IOSTAT=IER) NEWSDIR_ENTRY IF (IER.NE.0) THEN CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.RMS$_DUP) GO TO 10 ELSE F_COUNT = F_COUNT + 1 END IF RETURN END SUBROUTINE CONVERT_HEADER_TOBIN IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CALL SYS_BINTIM(NEWEST_EXDATE//' '//NEWEST_EXTIME,NEWEST_EXBTIM) CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,NEWEST_MSGBTIM) CALL SYS_BINTIM(SHUTDOWN_DATE//' '//SHUTDOWN_TIME,SHUTDOWN_BTIM) IF (REMOTE_SET.EQ.4) THEN CALL COPY2(NEWS_F_NEWEST_BTIM,NEWEST_MSGBTIM) CALL GET_MSGKEY(NEWEST_EXBTIM,NEWS_F_EXPIRED_DATE) END IF RETURN END SUBROUTINE CONVERT_ENTRY_TOBIN IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /LOCALPOST/ LOCAL_POST CALL SYS_BINTIM(EXDATE//' '//EXTIME,EX_BTIM) IF (REMOTE_SET.EQ.4) THEN CALL CONVERT_TO_GMT(MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,NEWS_POST_KEY) CALL SYS_BINTIM(NEWEST_DATE//' '//NEWEST_TIME,MSG_BTIM) ELSE CALL SYS_BINTIM(DATE//' '//TIME,MSG_BTIM) END IF IF (LOCAL_POST) THEN CALL SYS_BINTIM(DATE//' '//TIME & (:TRIM(TIME)-2)//'00',MSG_BTIM) CALL GET_MSGKEY(MSG_BTIM,NEWS_POST_KEY) END IF IF (REMOTE_SET.EQ.4) THEN NEWS_DESCRIP = DESCRIP NEWS_FROM = FROM NEWS_BLOCK = BLOCK NEWS_LENGTH = LENGTH NEWS_MSG_NUM = MSG_NUM CALL GET_MSGKEY(MSG_BTIM,NEWS_MSG_BTIM_KEY) CALL GET_MSGKEY(EX_BTIM,NEWS_EX_BTIM_KEY) ELSE CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) END IF RETURN END SUBROUTINE READ_FIRST_EXPIRED(NDEL) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /KEYID/ NEWS_KEYID COMMON /KEEPLOCK/ KEEPLOCK EX_BTIM(1) = 0 EX_BTIM(2) = 0 MSG_NUM = 0 ENTRY READ_NEXT_EXPIRED(NDEL) NEWS_KEYID = 2 KEEPLOCK = .TRUE. CALL GET_MSGKEY(EX_BTIM,MSG_KEY) CALL READDIR_KEYGE(NDEL) KEEPLOCK = .FALSE. NEWS_KEYID = 1 RETURN END SUBROUTINE READACL(FILENAME,ACLENT,ACLLENGTH) C C SUBROUTINE READACL C C FUNCTION: Reads the ACL of a file. C C PARAMETERS: C FILENAME - Name of file to check. C ACLENT - String which will be large enough to hold ACL information. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' INCLUDE '($ACLDEF)' CHARACTER ACLENT*(*),OUTPUT*80,ACLSTR*256,FILENAME*(*) CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST),,,) BIG = .NOT.IER IF (BIG) THEN IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) ACLLENGTH = ACL$S_ADDACLENT CTXT = 0 END IF DO ACC_TYPE=1,2 POINT = 1 OUTLEN = 0 DO WHILE ((POINT.LT.ACLLENGTH).AND.IER) IF (.NOT.BIG) THEN IER = SYS$FORMAT_ACL(ACLENT(POINT:POINT-1+ & ICHAR(ACLENT(POINT:POINT))),ACLLEN,ACLSTR,,,,) ELSE CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,FILENAME,%VAL(ACL_ITMLST) & ,,,CTXT,,) IER = SYS$FORMAT_ACL(ACLENT(:ICHAR(ACLENT(:1))), & ACLLEN,ACLSTR,,,,) CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) IF (ACCESS.EQ.0) IER = .FALSE. END IF AC = INDEX(ACLSTR,',ACCESS') IF ((ACC_TYPE.EQ.1.AND.INDEX(ACLSTR(AC:),'WRITE').GT.0).OR. & (ACC_TYPE.EQ.2.AND.INDEX(ACLSTR(AC:),'READ').GT.0.AND. & INDEX(ACLSTR(AC:),'WRITE').EQ.0)) THEN START_ID = INDEX(ACLSTR,'=') + 1 END_ID = INDEX(ACLSTR,',ACCESS') - 1 IF (ACLSTR(END_ID:END_ID).EQ.']') THEN START_ID = END_ID - 1 ASCII = .FALSE. DO WHILE (ACLSTR(START_ID:START_ID).NE.'['.AND. & ACLSTR(START_ID:START_ID).NE.'='.AND. & (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII)) IF (ACLSTR(START_ID:START_ID).NE.','.AND. & (ACLSTR(START_ID:START_ID).LT.'0'.OR. & ACLSTR(START_ID:START_ID).GT.'9')) ASCII = .TRUE. IF (ACLSTR(START_ID:START_ID).NE.','.OR..NOT.ASCII) THEN START_ID = START_ID - 1 END IF END DO IF (ASCII) THEN START_ID = START_ID + 1 END_ID = END_ID - 1 IF (ACLSTR(START_ID:START_ID).EQ.'*') THEN START_ID = INDEX(ACLSTR,'=') + 1 END_ID = INDEX(ACLSTR,'ACCESS') - 2 END IF END IF END IF IF (OUTLEN.EQ.0) THEN IF (FILENAME.NE.BULLUSER_FILE) THEN IF (ACC_TYPE.EQ.1) THEN WRITE (6,'( & '' These users can read and write to this folder:'')') ELSE WRITE (6,'( & '' These users can only read this folder:'')') END IF ELSE WRITE (6,'('' The following are rights identifiers'', & '' which will give privileges.'')') END IF OUTLEN = 1 END IF IDLEN = END_ID - START_ID + 1 IF (OUTLEN+IDLEN-1.GT.80) THEN WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-1) OUTPUT = ACLSTR(START_ID:END_ID)//',' OUTLEN = IDLEN + 2 ELSE IF (OUTLEN+IDLEN-1.EQ.80) THEN WRITE (6,'(1X,A)') & OUTPUT(:OUTLEN-1)//ACLSTR(START_ID:END_ID) OUTLEN = 1 ELSE OUTPUT(OUTLEN:) = ACLSTR(START_ID:END_ID)//',' OUTLEN = OUTLEN + IDLEN + 1 END IF END IF POINT = POINT + ICHAR(ACLENT(POINT:POINT)) END DO IF (OUTLEN.GT.1) WRITE (6,'(1X,A)') OUTPUT(:OUTLEN-2) END DO RETURN END SUBROUTINE CONVERT_INFFILE IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFILES.INC' OPEN (UNIT=10,FILE=BULLINF_FILE,STATUS='OLD', & ACCESS='KEYED',RECORDTYPE='FIXED', & IOSTAT=IER,ORGANIZATION='INDEXED', & KEY=(1:12:CHARACTER)) INQUIRE (UNIT=10,RECORDSIZE=RECL) IF ((RECL-3)/2.GT.FOLDER_MAX) THEN WRITE (6,'('' ERROR: Old data files have more folders'', & '' than was specified with BULLUSER.INC.'')') WRITE (6,'('' Recompile with correct FOLDER_MAX.'')') IF (USERNAME.EQ.'DECNET') THEN CALL SYS$DELPRC(,) ELSE CALL ENABLE_CTRL CALL SYS$CANEXH() CALL EXIT END IF END IF RECL = (RECL-3)/2 OPEN (UNIT=9,FILE=BULLINF_FILE,STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',RECORDSIZE=FOLDER_MAX*2+3, & IOSTAT=IER,ORGANIZATION='INDEXED', & KEY=(1:12:CHARACTER)) DO WHILE (IER.EQ.0) READ (10,IOSTAT=IER) TEMP_USER,((LAST_READ_BTIM(J,I),J=1,2),I=1,RECL) IF (IER.EQ.0) WRITE (9) TEMP_USER, & ((LAST_READ_BTIM(J,I),J=1,2),I=1,FOLDER_MAX) END DO CLOSE (UNIT=10,STATUS='DELETE') CLOSE (UNIT=9) RETURN END SUBROUTINE ERROR_AND_EXIT IMPLICIT INTEGER (A-Z) CALL ERRSNS(IDUMMY,IER) CALL SYS_GETMSG(IER) CALL ENABLE_CTRL_EXIT RETURN END SUBROUTINE COPY_ACL(INFILE,OUTFILE) C C SUBROUTINE COPY_ACL C C FUNCTION: C Copy ACLs from one file to another file C IMPLICIT INTEGER (A-Z) INCLUDE '($ACLDEF)' CHARACTER*(*) INFILE,OUTFILE CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(4,ACL$C_ACLLENGTH,%LOC(ACLLENGTH)) ! Get length needed to store acl output CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) CALL LIB$GET_VM(ACLLENGTH+12,ACLSTR) ! Create character string to CALL MAKE_CHAR(%VAL(ACLSTR),ACLLENGTH,ACLLENGTH) ! store acl CALL COPY_ACL1(INFILE,OUTFILE,%VAL(ACLSTR),ACLLENGTH) ! Pass location of string CALL LIB$FREE_VM(ACLLENGTH+12,ACLSTR) RETURN END SUBROUTINE COPY_ACL1(INFILE,OUTFILE,ACLENT,ACLLENGTH) C C SUBROUTINE COPY_ACL1 C C FUNCTION: Called by COPY_ACL to actually do the copy. Need 2 routines C since must convert location of string into a character string. C IMPLICIT INTEGER (A-Z) INCLUDE '($ACLDEF)' CHARACTER ACLENT*(*),INFILE*(*),OUTFILE*(*) CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_READACL,%LOC(ACLENT)) CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST),,,,,) ! Read input file acl IF (.NOT.IER) THEN IER = SYS$PARSE_ACL('(ID=*,ACCESS=NONE)',ACLENT,,) IF (.NOT.IER) RETURN ACLLENGTH = ACL$S_ADDACLENT CTXT = 0 DO WHILE (IER) CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT, & %LOC(ACLENT)) CALL END_ITMLST(ACL1_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL & (,ACL$C_FILE,OUTFILE,%VAL(ACL1_ITMLST),,,) CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(ACLLENGTH,ACL$C_FNDACETYP,%LOC(ACLENT)) CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,INFILE,%VAL(ACL_ITMLST) & ,,,CTXT,,) CALL LIB$MOVC3(4,%REF(ACLENT(5:)),ACCESS) IF (ACCESS.EQ.0) RETURN ! ID=*, ACCESS=NONE, which has ! (and must) be applied first END DO RETURN END IF CALL INIT_ITMLST ! Initialize item list POINT = 1 DO WHILE (POINT.LT.ACLLENGTH) ! Transfer all acls to output file CALL ADD_2_ITMLST(ICHAR(ACLENT(POINT:POINT)),ACL$C_ADDACLENT, & %LOC(ACLENT(POINT:))) POINT = POINT + ICHAR(ACLENT(POINT:POINT)) END DO CALL END_ITMLST(ACL_ITMLST) ! Get address of itemlist IER = SYS$CHANGE_ACL(,ACL$C_FILE,OUTFILE,%VAL(ACL_ITMLST),,,) RETURN END SUBROUTINE CHECK_DIR_ACCESS() IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' CHARACTER*80 TEST,TEST1 DATA CHECKED /.FALSE./ IF (CHECKED) RETURN CHECKED = .TRUE. IF (SYS_TRNLNM_SYSTEM(FOLDER_DIRECTORY,TEST)) THEN IER = SYS_TRNLNM(FOLDER_DIRECTORY,TEST1) IF (IER) IER = TEST.NE.TEST1 IF (IER) THEN TEST1 = BULLNEWS_FILE CALL ADD_DIRECTORY(BULLNEWS_FILE) C = 0 IER = LIB$FIND_FILE(BULLNEWS_FILE,BULLNEWS_FILE,C) BULLNEWS_FILE = TEST1 END IF IF (.NOT.IER) THEN TEST1 = FOLDER_DIRECTORY FOLDER_DIRECTORY = TEST END IF CALL ADD_DIRECTORY(BULLNEWS_FILE) IF (.NOT.IER) FOLDER_DIRECTORY = TEST1 ELSE CALL ADD_DIRECTORY(BULLNEWS_FILE) END IF CALL CHECK_DIR(FOLDER_DIRECTORY,.FALSE.) CALL CHECK_DIR(NEWS_DIRECTORY,.FALSE.) CALL ADD_DIRECTORIES RETURN END SUBROUTINE ADD_DIRECTORIES INCLUDE 'BULLFILES.INC' CALL ADD_DIRECTORY(BULLUSER_FILE) CALL ADD_DIRECTORY(BULLFOLDER_FILE) CALL ADD_DIRECTORY(BULLINF_FILE) RETURN END LOGICAL FUNCTION CHECK_DIR(DIRECTORY,LIBRARY) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' CHARACTER*(*) DIRECTORY CHARACTER*80 TEST,TEST1 CHECK_DIR = PRESENT(BULLUSER_FILE,DIRECTORY,TEST).AND. & PRESENT(BULLFOLDER_FILE,DIRECTORY,TEST).AND. & PRESENT(BULLINF_FILE,DIRECTORY,TEST) IF (CHECK_DIR) THEN IF (SYS_TRNLNM(DIRECTORY,TEST)) DIRECTORY = TEST RETURN END IF TEST = ' ' IF (INDEX(DIRECTORY,']').EQ.0) THEN CALL SYS_TRNLNM(DIRECTORY,TEST1) ELSE TEST1 = DIRECTORY END IF IER = 1 DO WHILE (TEST.NE.TEST1.AND.IER) IER = SYS_TRNLNM_SYSTEM_INDEX('BULL_DIR_LIST',TEST) END DO IF (.NOT.LIBRARY.AND.TEST.EQ.' ') THEN IER = SYS_TRNLNM_SYSTEM(DIRECTORY,TEST) IF (.NOT.IER.AND.TEST1.EQ.DIRECTORY) RETURN END IF IF (TEST.NE.TEST1) THEN IF (LIBRARY) THEN WRITE (6,'('' ERROR: Not a valid library. '')') RETURN END IF IF (INDEX(TEST1,':').EQ.0) TEST1 = TEST1(:TRIM(TEST1))//':' CALL DISABLE_PRIVS OPEN(UNIT=3,FILE=TEST1(:TRIM(TEST1))// & 'BULL.SCR',STATUS='NEW',IOSTAT=IER) CLOSE(UNIT=3,STATUS='DELETE') CALL ENABLE_PRIVS IF (IER.NE.0) THEN WRITE (6,'('' ERROR: No access to directory: '',A)') & TEST1(:TRIM(TEST1)) CALL EXIT END IF DIRECTORY = TEST1 ELSE IF (INDEX(TEST,':').EQ.0) TEST = TEST(:TRIM(TEST))//':' DIRECTORY = TEST DO WHILE (IER) IER = SYS_TRNLNM_SYSTEM_INDEX('BULL_DIR_LIST',TEST) END DO CHECK_DIR = .TRUE. END IF RETURN END LOGICAL FUNCTION PRESENT(FILE,DIR,TEST) IMPLICIT INTEGER (A-Z) CHARACTER*(*) FILE,DIR,TEST FILE = FILE(INDEX(FILE,':')+1:) FILE = FILE(INDEX(FILE,']')+1:) IF (INDEX(DIR,':').EQ.0.AND.INDEX(DIR,'[').EQ.0.AND. & INDEX(DIR,'<').EQ.0) DIR = DIR(:TRIM(DIR))//':' C = 0 PRESENT = LIB$FIND_FILE(DIR(:TRIM(DIR))//FILE,TEST,C) RETURN END SUBROUTINE ADD_DIRECTORY(DIRECTORY) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' CHARACTER*(*) DIRECTORY DIRECTORY = DIRECTORY(INDEX(DIRECTORY,':')+1:) DIRECTORY = DIRECTORY(INDEX(DIRECTORY,']')+1:) IF (INDEX(FOLDER_DIRECTORY,':').EQ.0) FOLDER_DIRECTORY & = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//':' DIRECTORY = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) & //DIRECTORY RETURN END SUBROUTINE SET_LIBRARY IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' INCLUDE 'BULLFOLDER.INC' COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /COMMAND_LINE/ INCMD CHARACTER*256 INCMD CALL CLI$GET_VALUE('LIBRARY',BULL_PARAMETER,LEN_P) IF (CHECK_DIR(BULL_PARAMETER,.TRUE.)) THEN FOLDER_DIRECTORY = BULL_PARAMETER CALL ADD_DIRECTORIES FOLDER_SET = .FALSE. FOLDER_NUMBER = 0 CALL SELECT_FOLDER(.FALSE.,IER) WRITE (6,'('' Resetting to '',A,'' folder.'')') & FOLDER(:TRIM(FOLDER)) CALL UPDATE_USERINFO CALL OPEN_USERINFO INCMD = 'SHOW' CALL UPDATE_READ(0) END IF RETURN END SUBROUTINE SHOW_LIBRARY IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER IF (CLI$PRESENT('ALL')) THEN IER = 1 N = 1 DO WHILE (IER) IER = SYS_TRNLNM_SYSTEM_INDEX('BULL_DIR_LIST',BULL_PARAMETER) IF (IER) THEN IF (N.EQ.1) THEN WRITE (6,'('' The following are valid libraries:'')') N = 0 END IF WRITE (6,'(1X,A)') BULL_PARAMETER END IF END DO IF (N.EQ.1) WRITE (6,'('' No libraries are present.'')') ELSE WRITE (6,'('' Present library is: '',A)') & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) END IF RETURN END SUBROUTINE SET_BULLNEWSDIR_FILE(FN) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' COMMON /NEWSDIR_FILE/ BULLNEWSDIR_FILE CHARACTER*80 BULLNEWSDIR_FILE BULLNEWSDIR_FILE = ' ' ENCODE(6,'(I6)',BULLNEWSDIR_FILE) FN BULLNEWSDIR_FILE = BULLNEWSDIR_FILE(FIRST_ALPHA(BULLNEWSDIR_FILE):) L = TRIM(BULLNEWSDIR_FILE) BULLNEWSDIR_FILE = FOLDER_FILE(:MINGT0(INDEX(FOLDER_FILE,'.]'), & INDEX(FOLDER_FILE,'.BULLNEWS')))//'BULLNEWSDIR.'// & BULLNEWSDIR_FILE(:L-3)//']'// & BULLNEWSDIR_FILE(L-2:TRIM(BULLNEWSDIR_FILE))//'.' RETURN END