C C BULLETIN9.FOR, Version 4/10/91 C Purpose: Contains subroutines for the bulletin board utility program. C Environment: VAX/VMS C Usage: Invoked by the BULLETIN command. C Programmer: Mark R. London C C Copyright (c) 1990 C Property of Massachusetts Institute of Technology, Cambridge MA 02139. C This program cannot be copied or distributed in any form for non-MIT C use without specific written approval of MIT Plasma Fusion Center C Management. C SUBROUTINE DELETE_NODE C C SUBROUTINE DELETE_NODE C C FUNCTION: Deletes files sent via ADD/NODES at remote hosts. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, & NODE_ERROR,POINT_NODE CHARACTER*32 NODES(10) LOGICAL LOCAL_NODE_FOUND,NODE_ERROR CHARACTER INLINE*80 CALL GET_NODE_INFO IF (NODE_ERROR) GO TO 940 IF (NODE_NUM.EQ.0.OR.LOCAL_NODE_FOUND) THEN WRITE (6,'('' ERROR: Cannot specify local node.'')') GO TO 999 END IF IER = CLI$GET_VALUE('SUBJECT',DESCRIP) DO POINT_NODE=1,NODE_NUM ! Write out command to nodes NLEN = TRIM(NODES(POINT_NODE)) ! Length of node name INLINE = 'DELETE/SUBJECT="'//DESCRIP(:TRIM(DESCRIP)) WRITE (POINT_NODE+9,'(A)',ERR=940) INLINE READ (POINT_NODE+9,'(A)',ERR=940,END=940) INLINE IF (INLINE.EQ.'END') THEN WRITE (6,'('' Message successfully deleted from node '',A)') & NODES(POINT_NODE) ELSE WRITE (6,'('' Error while deleting message to node '',A)') & NODES(POINT_NODE) WRITE (6,'(A)') INLINE END IF END DO GO TO 999 910 WRITE (6,1010) GO TO 999 940 WRITE (6,1015) NODES(POINT_NODE) 999 DO WHILE (NODE_NUM.GT.0) CLOSE(UNIT=9+NODE_NUM) NODE_NUM = NODE_NUM - 1 END DO RETURN 1010 FORMAT (' ERROR: Deletion aborted.') 1015 FORMAT (' ERROR: Unable to reach node ',A) END SUBROUTINE SET_FOLDER_FLAG(SETTING,FLAG,FLAGNAME) C C SUBROUTINE SET_FOLDER_FLAG C C FUNCTION: Sets or clears specified flag for folder C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFILES.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER*(*) FLAGNAME IF (REMOTE_SET.EQ.3) THEN WRITE (6,'('' ERROR: Command invalid for folder.'')') ELSE IF (FLAG.EQ.7.AND..NOT.SETPRV_PRIV()) THEN WRITE (6,'('' ERROR: Privileges required for this command.'')') ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN CALL OPEN_BULLFOLDER ! Open folder file CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) IF (SETTING) THEN FOLDER_FLAG = IBSET(FOLDER_FLAG,FLAG) ELSE FOLDER_FLAG = IBCLR(FOLDER_FLAG,FLAG) END IF CALL REWRITE_FOLDER_FILE CALL CLOSE_BULLFOLDER WRITE (6,'(1X,A,'' has been modified for folder.'')') & FLAGNAME ELSE WRITE (6,'(1X,'' You are not authorized to modify '',A)') & FLAGNAME//'.' END IF RETURN END SUBROUTINE SET_FOLDER_EXPIRE_LIMIT(LIMIT) C C SUBROUTINE SET_FOLDER_EXPIRE_LIMIT C C FUNCTION: Sets folder expiration limit. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFILES.INC' COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT IF (REMOTE_SET.EQ.3) THEN WRITE (6,'('' ERROR: Command invalid for folder. '')') ELSE IF (LIMIT.LT.0) THEN WRITE (6,'('' ERROR: Invalid expiration length specified.'')') ELSE IF (FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN CALL OPEN_BULLFOLDER ! Open folder file CALL READ_FOLDER_FILE_KEYNAME(FOLDER,IER) F_EXPIRE_LIMIT = LIMIT CALL REWRITE_FOLDER_FILE CALL CLOSE_BULLFOLDER WRITE (6,'('' Folder expiration date modified.'')') ELSE WRITE (6,'('' You are not allowed to modify folder.'')') END IF RETURN END SUBROUTINE MERGE IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' CHARACTER*(DIR_RECORD_LENGTH) BULLDIR_ENTRY_SAVE ENTRY INITIALIZE_MERGE(IER1) DO WHILE (FILE_LOCK(IER1,IER2)) OPEN (UNIT=13,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE)) & //'.TMPDIR',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 DO IF (IER1.NE.0) RETURN NBULL = 0 WRITE(13,IOSTAT=IER1) BULLDIR_HEADER CALL CONVERT_HEADER_FROMBIN TO_POINTER = 1 RETURN ENTRY ADD_MERGE_TO(IER1) IER1 = 0 DO WHILE (IER1.EQ.0) BULLDIR_ENTRY_SAVE = BULLDIR_ENTRY CALL READDIR(TO_POINTER,IER) DIFF = COMPARE_BTIM(%REF(BULLDIR_ENTRY_SAVE),MSG_BTIM) IF (DIFF.LT.0.OR.TO_POINTER+1.NE.IER) THEN BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE CALL CONVERT_ENTRY_FROMBIN RETURN END IF NBULL = NBULL + 1 MSG_NUM = NBULL CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY NEWEST_DATE = DATE NEWEST_TIME = TIME TO_POINTER = TO_POINTER + 1 BULLDIR_ENTRY = BULLDIR_ENTRY_SAVE END DO CLOSE (UNIT=13) RETURN ENTRY ADD_MERGE_FROM(IER1) NEWEST_DATE = DATE NEWEST_TIME = TIME DIFF = COMPARE_DATE(NEWEST_EXDATE,EXDATE) IF (DIFF.GT.0) THEN NEWEST_EXDATE = EXDATE NEWEST_EXTIME = EXTIME ELSE IF (DIFF.EQ.0) THEN DIFF = COMPARE_TIME(NEWEST_EXTIME,EXTIME) IF (DIFF.GT.0) NEWEST_EXTIME = EXTIME END IF IF ((SYSTEM.AND.4).EQ.4) THEN SHUTDOWN = SHUTDOWN + 1 SHUTDOWN_DATE = DATE SHUTDOWN_TIME = TIME END IF BLOCK = NBLOCK - LENGTH NBULL = NBULL + 1 MSG_NUM = NBULL CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY RETURN ENTRY ADD_MERGE_REST(IER1) CALL UPDATE_LOGIN(.TRUE.) DO WHILE (IER1.EQ.0) CALL READDIR(TO_POINTER,IER) IF (TO_POINTER+1.NE.IER) THEN READ (13,KEYID=0,KEY=0,IOSTAT=IER1) CALL CONVERT_HEADER_TOBIN REWRITE(13,IOSTAT=IER1) BULLDIR_HEADER IF (IER1.EQ.0) THEN CLOSE (UNIT=13,DISPOSE='KEEP') CALL LIB$RENAME_FILE(FOLDER_FILE(:TRIM(FOLDER_FILE))// & '.TMPDIR',FOLDER_FILE(:TRIM(FOLDER_FILE))//'.BULLDIR') ELSE CLOSE (UNIT=13) END IF RETURN END IF NBULL = NBULL + 1 MSG_NUM = NBULL CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) WRITE(13,IOSTAT=IER1) BULLDIR_ENTRY NEWEST_DATE = DATE NEWEST_TIME = TIME TO_POINTER = TO_POINTER + 1 END DO CLOSE (UNIT=13) RETURN END SUBROUTINE SET_NOKEYPAD IMPLICIT INTEGER (A-Z) COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID COMMON /KEYPAD/ KEYPAD_MODE INCLUDE '($SMGDEF)' KEYPAD_MODE = 0 TERM = SMG$M_KEY_TERMINATE IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'SET KEYPAD',) RETURN END SUBROUTINE SET_KEYPAD IMPLICIT INTEGER (A-Z) COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID COMMON /KEYPAD/ KEYPAD_MODE INCLUDE '($SMGDEF)' KEYPAD_MODE = 1 TERM = SMG$M_KEY_TERMINATE IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,1) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF1',,,,'GOLD') IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2',,TERM,'HELP',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF2','GOLD',TERM,'SET NOKEYPAD',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3',,,'EXTRACT ',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF3','GOLD',,'FILE ',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4',,TERM,'SHOW KEYPAD',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PF4','GOLD',TERM, & 'SHOW KEYPAD/PRINT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0',,TERM, & 'SHOW FOLDER/FULL',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP0','GOLD',TERM,'SHOW FLAGS',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1',,TERM,'BACK',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP1','GOLD',TERM,'NEXT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2',,TERM,'PRINT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP2','GOLD',TERM,'PRINT/NONOTIFY',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3',,TERM,'DIR',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP3','GOLD',TERM,'DIR/FOLDER',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4',,TERM,'CURRENT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP4','GOLD',TERM,'CURRENT/EDIT ',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5',,TERM,'RESPOND',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP5','GOLD',TERM,'RESP/EDIT/EXT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP6',,TERM,'LAST',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7',,TERM,'ADD',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP7','GOLD',TERM,'ADD/EDIT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8',,TERM,'REPLY',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP8','GOLD',TERM,'REPL/EDIT/EXT',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9',,TERM,'MAIL',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'KP9','GOLD',TERM,'MAIL/NOHEAD',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS',,TERM,'READ/NEW',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'MINUS','GOLD',TERM,'SHOW NEW',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA',,TERM,'DIR/NEW',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'COMMA','GOLD',TERM,'INDEX',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD',,TERM,'DELETE',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'PERIOD','GOLD',TERM,'UNDELETE',) IER = SMG$ADD_KEY_DEF(KEY_TABLE_ID,'ENTER','GOLD',,'SELECT ',) RETURN END SUBROUTINE SHOW_KEYPAD(LIBRARY) IMPLICIT INTEGER (A-Z) EXTERNAL LIB$PUT_OUTPUT,PRINT_OUTPUT CHARACTER*(*) LIBRARY INCLUDE '($HLPDEF)' IF (CLI$PRESENT('PRINT')) THEN OPEN (UNIT=8,STATUS='NEW',FILE='SYS$LOGIN:KEYPAD.DAT', & IOSTAT=IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR WHILE OPENING FILE TO PRINTER.'')') ELSE CALL LBR$OUTPUT_HELP(PRINT_OUTPUT,,'KEYPAD' & ,LIBRARY,HLP$M_HELP) CLOSE (UNIT=8,DISP='PRINT/DELETE') END IF ELSE CALL LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,'KEYPAD' & ,LIBRARY,HLP$M_HELP) END IF RETURN END INTEGER FUNCTION PRINT_OUTPUT(INPUT) IMPLICIT INTEGER (A-Z) CHARACTER*(*) INPUT WRITE (8,'(1X,A)',IOSTAT=IER) INPUT(:TRIM(INPUT)) IF (IER.EQ.0) PRINT_OUTPUT = 1 RETURN END SUBROUTINE OUTPUT_HELP(PARAMETER,LIBRARY) C C SUBROUTINE OUTPUT_HELP C C FUNCTION: C To create interactive help session. Prompting is enabled. C INPUTS: C PARAMETER - Character string. Optional input parameter C containing a list of help keys. C LIBRARY - Character string. Name of help library. C IMPLICIT INTEGER (A-Z) INCLUDE '($LBRDEF)' COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO CHARACTER*80 HELP_INPUT COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT CHARACTER*20 KEY(10) DIMENSION KEYL(10) EXTERNAL PUT_OUTPUT CHARACTER*(*) LIBRARY,PARAMETER CHARACTER*80 PROMPT DATA DISPLAY_ID/0/,KEYBOARD_ID/0/ IF (KEYBOARD_ID.EQ.0) THEN IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID) END IF CALL STR$TRIM(HELP_INPUT,PARAMETER,HELP_INPUT_LEN) ! Trim input CALL LBR$INI_CONTROL(LINDEX,LBR$C_READ) ! Init library read CALL LBR$OPEN(LINDEX,LIBRARY) ! Specify library name DO I=1,10 ! Initialize key lengths KEYL(I) = 0 END DO NKEY = 0 ! Number of help keys DO WHILE (1) ! Do until CTRL-Z entered or no more keys HELP_PAGE = 0 ! Init line counter NEED_ERASE = .TRUE. ! Need to erase screen OLD_NKEY = NKEY ! Save old key count EXACT = .TRUE. ! Exact key match DO WHILE (NKEY.LT.10.AND.HELP_INPUT_LEN.GT.0.AND. & HELP_INPUT(:1).NE.'?') ! Break input into keys NKEY = NKEY + 1 ! Increment key counter DO WHILE (HELP_INPUT(1:1).EQ.' '.AND.HELP_INPUT_LEN.GT.0) HELP_INPUT = HELP_INPUT(2:HELP_INPUT_LEN) ! Strip spaces HELP_INPUT_LEN = HELP_INPUT_LEN - 1 ! at start of input END DO NEXT_KEY = 2 DO WHILE (NEXT_KEY.LE.HELP_INPUT_LEN ! Search for & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.' ' ! space or & .AND.HELP_INPUT(NEXT_KEY:NEXT_KEY).NE.'/') ! backslash NEXT_KEY = NEXT_KEY + 1 ! indicating start of next key END DO IF (NEXT_KEY.GT.HELP_INPUT_LEN) THEN ! Found the last key KEY(NKEY) = HELP_INPUT(:HELP_INPUT_LEN) ! Key string KEYL(NKEY) = HELP_INPUT_LEN ! Key length HELP_INPUT_LEN = 0 ELSE ! Found the next key KEY(NKEY) = HELP_INPUT(:NEXT_KEY-1) HELP_INPUT = HELP_INPUT(NEXT_KEY:HELP_INPUT_LEN) KEYL(NKEY) = NEXT_KEY - 1 HELP_INPUT_LEN = HELP_INPUT_LEN - NEXT_KEY + 1 END IF END DO HELP_INPUT_LEN = 0 IER = LBR$GET_HELP(LINDEX,,PUT_OUTPUT,, ! Display help & KEY(1)(:KEYL(1)),KEY(2)(:KEYL(2)), & KEY(3)(:KEYL(3)),KEY(4)(:KEYL(4)),KEY(5)(:KEYL(5)), & KEY(6)(:KEYL(6)),KEY(7)(:KEYL(7)),KEY(8)(:KEYL(8)), & KEY(9)(:KEYL(9)),KEY(10)(:KEYL(10))) IF (IER.EQ.0.AND.HELP_INPUT_LEN.GT.0) IER = 1 ! IER = 0 special case means input given to full screen prompt IF (KEY(NKEY).EQ.'*'.OR..NOT.EXACT) THEN ! If not exact match DO I=OLD_NKEY+1,NKEY ! then don't update KEYL(I) = 0 ! new keys END DO NKEY = OLD_NKEY END IF IF (IER.AND.NKEY.GT.0.AND.OTHERINFO.EQ.0) THEN ! No subtopics? KEYL(NKEY) = 0 ! Back up one key level NKEY = NKEY - 1 END IF DO WHILE (HELP_INPUT_LEN.EQ.0.AND.IER.AND.NKEY.GE.0) IF (NKEY.EQ.0) THEN ! If top level, prompt for topic IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, & HELP_INPUT,'Topic? ',HELP_INPUT_LEN) ELSE ! If not top level, prompt for subtopic LPROMPT = 0 ! Create subtopic prompt line DO I=1,NKEY ! Put spaces in between keys PROMPT = PROMPT(:LPROMPT)//KEY(I)(:KEYL(I))//' ' LPROMPT = LPROMPT + KEYL(I) + 1 END DO PROMPT = PROMPT(:LPROMPT)//'Subtopic? ' LPROMPT = LPROMPT + 10 IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, & HELP_INPUT,PROMPT(:LPROMPT),HELP_INPUT_LEN) END IF CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) IF (IER.AND.HELP_INPUT_LEN.EQ.0) THEN ! If RETURN entered KEYL(NKEY) = 0 ! Back up one key level NKEY = NKEY - 1 END IF END DO IF (.NOT.IER.OR.NKEY.LT.0) THEN ! If CTRL-Z above top level, CALL LIB$PUT_OUTPUT(' ') ! Skip line CALL LBR$CLOSE(LINDEX) ! then close library, RETURN ! and end help session. END IF END DO END INTEGER FUNCTION PUT_OUTPUT(INPUT,INFO,DATA,LEVEL) C C FUNCTION PUT_OUTPUT C C FUNCTION: C Output routine for input from LBR$GET_HELP. Displays C help text on terminal with full screen prompting. C INPUTS: C INPUT - Character string. Line of input text. C INFO - Longword. Contains help flag bits. C DATA - Longword. Not presently used. C LEVEL - Longword. Contains current key level. C IMPLICIT INTEGER (A-Z) INCLUDE '($HLPDEF)' COMMON /LEVELS/ KEY,KEYL,NKEY,OLD_NKEY,EXACT CHARACTER*20 KEY(10) DIMENSION KEYL(10) COMMON /HELP/ HELP_PAGE,HELP_INPUT,HELP_INPUT_LEN COMMON /HELP/ NEED_ERASE,KEYBOARD_ID,KEY_TABLE_ID,OTHERINFO CHARACTER*80 HELP_INPUT COMMON /PAGE/ PAGE_LENGTH,PAGE_WIDTH,PAGING CHARACTER INPUT*(*) CHARACTER SPACES*20 DATA SPACES /' '/ OTHERINFO = INFO.AND.HLP$M_OTHERINFO IF ((INFO.AND.HLP$M_NOHLPTXT).NE.0) THEN ! Key cannot be found NEED_ERASE = .FALSE. ! Don't erase screen IF (HELP_PAGE.EQ.0) THEN ! If first line of help text DO I=OLD_NKEY+1,NKEY ! remove any new keys that KEYL(I) = 0 ! were inputted, as they are END DO ! not valid, as no match NKEY = OLD_NKEY ! could be found. END IF ELSE IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0.AND.NKEY.GT.0.AND. & LEVEL.GT.OLD_NKEY.AND.KEY(NKEY)(:KEYL(NKEY)).NE.'*'.AND. & %LOC(INPUT).NE.0) THEN ! If text contains key names ! Update if not wildcard search and they are new keys IF (KEYL(LEVEL).GT.0) THEN ! If key already updated EXACT = .FALSE. ! Must be more than one match possible END IF ! so indicate not exact match. START_KEY = 1 ! String preceeding spaces. DO WHILE (INPUT(START_KEY:START_KEY).EQ.' ') START_KEY = START_KEY + 1 END DO KEY(LEVEL) = INPUT(START_KEY:) ! Store new key CALL STR$TRIM(KEY(LEVEL),KEY(LEVEL),KEYL(LEVEL)) ! & key length ELSE IF (HELP_PAGE.EQ.0) THEN ! If first line of text, DO I=OLD_NKEY+1,NKEY ! remove any new keys that KEYL(I) = 0 ! were just inputted, allowing END DO ! this routine to fill them. END IF IF (NEED_ERASE) THEN ! Need to erase screen? IER = LIB$ERASE_PAGE(1,1) ! i.e. start of new topic. NEED_ERASE = .FALSE. END IF HELP_PAGE = HELP_PAGE + 1 ! Increment screen counter IF (PAGING.AND.HELP_PAGE.GT.PAGE_LENGTH-2) THEN ! End of page? HELP_PAGE = 0 ! Reinitialize screen counter CALL LIB$PUT_OUTPUT(' ') ! Skip line and prompt for next screen IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID, & HELP_INPUT,'Press RETURN to continue ... ',HELP_INPUT_LEN) CALL STR$TRIM(HELP_INPUT,HELP_INPUT,HELP_INPUT_LEN) ! Trim input IF (.NOT.IER.OR.HELP_INPUT_LEN.GT.0) THEN ! CTRL-Z or Text input? EXACT = .TRUE. ! If more than one match was found and being ! displayed, text input specifies that the ! current displayed match is desired. PUT_OUTPUT = 0 ! Stop any more of current help display. ELSE ! Else if RETURN entered IER = LIB$ERASE_PAGE(1,1) ! Erase display NSPACES = LEVEL*2 ! Number of spaces to indent output IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 ! Key name lines are indented 2 less than help description. IF (NSPACES.GT.0) THEN ! Add spaces if present to output PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) ELSE ! Else just output text. PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) END IF HELP_PAGE = 1 ! Increment page counter. END IF ELSE ! Else if not end of page NSPACES = LEVEL*2 ! Just output text line IF ((INFO.AND.HLP$M_KEYNAMLIN).NE.0) NSPACES = NSPACES - 2 IF (NSPACES.GT.0) THEN PUT_OUTPUT = LIB$PUT_OUTPUT(SPACES(:NSPACES)//INPUT) ELSE PUT_OUTPUT = LIB$PUT_OUTPUT(INPUT) END IF END IF RETURN END SUBROUTINE SHOW_VERSION IMPLICIT INTEGER (A-Z) CHARACTER VERSION*10,DATE*23 CALL READ_HEADER(VERSION,DATE) WRITE (6,'(A)') ' BULLETIN Version '//VERSION(:TRIM(VERSION)) WRITE (6,'(A)') ' Linked on '//DATE(:TRIM(DATE)) RETURN END SUBROUTINE TAG(ADD_OR_DEL) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' COMMON /TAGS/ BULL_TAG,READ_TAG DATA BULL_TAG /.FALSE./,READ_TAG /.FALSE./ COMMON /POINT/ BULL_POINT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER EXTERNAL CLI$_ABSENT IF (.NOT.BULL_TAG) THEN CALL OPEN_NEW_TAG(IER) IF (.NOT.IER) RETURN 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) ELSE CALL DEL_TAG(IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Message was not marked.'')') END IF END IF RETURN END IF CALL OPEN_BULLDIR_SHARED IER1 = 0 DO WHILE (CLI$GET_VALUE('NUMBER',BULL_PARAMETER,LEN_P) & .NE.%LOC(CLI$_ABSENT).AND.IER1.EQ.0) ! Get the specified messages DECODE(LEN_P,'(I)',BULL_PARAMETER) MESSAGE_NUMBER CALL READDIR(MESSAGE_NUMBER,IER) ! Get info for bulletin IF (IER.NE.MESSAGE_NUMBER+1) THEN ! Was bulletin found? WRITE(6,1030) ! If not, then error out ELSE IF (ADD_OR_DEL) THEN CALL ADD_TAG(IER1) ELSE CALL DEL_TAG(IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Message '',I, & '' was not marked.'')') MESSAGE_NUMBER END IF END IF END DO CALL CLOSE_BULLDIR RETURN 1010 FORMAT(' ERROR: You have not read any message.') 1030 FORMAT(' ERROR: Message was not found.') END SUBROUTINE ADD_TAG(IER) IMPLICIT INTEGER (A-Z) INCLUDE '($FORIOSDEF)' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' CHARACTER*12 TAG_KEY WRITE (13,IOSTAT=IER) TAG_KEY(FOLDER_NUMBER,MSG_KEY) IF (IER.EQ.FOR$IOS_INCKEYCHG) THEN WRITE (6,'('' Message was already marked.'')') ELSE IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Unable to add mark.'')') CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF END IF RETURN END SUBROUTINE DEL_TAG(IER) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' CHARACTER*12 TAG_KEY DO WHILE (REC_LOCK(IER)) READ (13,KEYEQ=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) END DO IF (IER.NE.0) RETURN DELETE (UNIT=13,IOSTAT=IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Unable to delete mark.'')') CALL ERRSNS(IDUMMY,IER1) IF (IER1.EQ.0) THEN WRITE (6,'('' IOSTAT error = '',I)') IER ELSE CALL SYS_GETMSG(IER1) END IF END IF RETURN END SUBROUTINE OPEN_OLD_TAG IMPLICIT INTEGER (A-Z) INCLUDE '($FORIOSDEF)' INCLUDE 'BULLUSER.INC' COMMON /TAGS/ BULL_TAG,READ_TAG COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) IF (.NOT.IER) RETURN NTRIES = 0 DO WHILE (FILE_LOCK(IER,IER1).AND.NTRIES.LE.30) OPEN (UNIT=13,FILE='BULL_MARK:'// & 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.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 (IER.EQ.0) BULL_TAG = .TRUE. RETURN END SUBROUTINE OPEN_NEW_TAG(IER) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' COMMON /TAGS/ BULL_TAG,READ_TAG COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER CHARACTER*64 BULL_MARK IER = SYS_TRNLNM('BULL_MARK',BULL_MARK) IF (.NOT.IER) THEN WRITE (6,'('' ERROR: BULL_MARK must be defined.'', & '' See HELP MARK.'')') RETURN ELSE IER1 = SYS_TRNLNM_SYSTEM('BULL_MARK',BULL_PARAMETER) IF (.NOT.IER1.OR.BULL_MARK.NE.BULL_PARAMETER) THEN IER = SYS_TRNLNM('BULL_MARK',BULL_PARAMETER) CALL DISABLE_PRIVS IER1 = 0 END IF OPEN (UNIT=13,FILE='BULL_MARK:'// & USERNAME(:TRIM(USERNAME))//'.BULLMARK',STATUS='NEW', & ACCESS='KEYED',RECORDTYPE='FIXED',SHARED, & RECORDSIZE=3, & FORM='UNFORMATTED',ORGANIZATION='INDEXED',IOSTAT=IER, & KEY=(1:12:CHARACTER)) 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 BULL_TAG = .TRUE. IER = 1 END IF END IF RETURN END CHARACTER*12 FUNCTION TAG_KEY(FOLDER_NUMBER,MSG_KEY) IMPLICIT INTEGER (A-Z) CHARACTER*(*) MSG_KEY CALL LIB$MOVC3(4,FOLDER_NUMBER,%REF(TAG_KEY)) 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 CHARACTER*12 TAG_KEY,INPUT_KEY IF (.NOT.BULL_TAG) THEN CALL OPEN_NEW_TAG(IER) IF (.NOT.IER) RETURN END IF MSG_KEY = BULLDIR_HEADER HEADER = .TRUE. GO TO 10 ENTRY GET_THIS_TAG(FOLDER_NUMBER,IER,MESSAGE) DO WHILE (REC_LOCK(IER)) READ (13,KEY=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) & INPUT_KEY END DO IF (IER.EQ.0) THEN UNLOCK 13 MESSAGE = MSG_NUM END IF RETURN ENTRY GET_THIS_OR_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) 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 ENTRY GET_NEXT_TAG(FOLDER_NUMBER,IER,MESSAGE) HEADER = .FALSE. 10 DO WHILE (REC_LOCK(IER)) READ (13,KEYGT=TAG_KEY(FOLDER_NUMBER,MSG_KEY),IOSTAT=IER) & INPUT_KEY END DO DO WHILE (1) 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 (FOLDER1_NUMBER.NE.FOLDER_NUMBER.OR.IER.NE.0) THEN IER = 1 UNLOCK 13 RETURN ELSE 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 CALL GET_MSGKEY(MSG_BTIM,MSG_KEY) INQUIRE (UNIT=2,OPENED=IER) IF (.NOT.IER) THEN CALL OPEN_BULLDIR CALL READDIR_KEYGE(IER) CALL CLOSE_BULLDIR ELSE CALL READDIR_KEYGE(IER) END IF 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_KEY = BULLDIR_HEADER END IF IER = 0 RETURN ELSE DELETE (UNIT=13) DO WHILE (REC_LOCK(IER)) READ (13,IOSTAT=IER) INPUT_KEY END DO END IF END IF END DO END SUBROUTINE FULL_DIR(INDEX_COUNT) C C Add INDEX command to BULLETIN, display directories of ALL C folders. Added per request of a faculty member for his private C board. Changes to BULLETIN.FOR should be fairly obvious. C C Brian Nelson, Brian@uoft02.bitnet (or .ccnet, node 8.2) C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFILES.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' COMMON /POINT/ BULL_POINT COMMON /TAGS/ BULL_TAG,READ_TAG DATA FOLDER_Q1/0/ BULL_POINT = 0 IF (NUM_FOLDERS.GT.0.AND..NOT.CLI$PRESENT('RESTART') & .AND.INDEX_COUNT.EQ.1) THEN INDEX_COUNT = 2 DIR_COUNT = 0 END IF IF (INDEX_COUNT.EQ.1) THEN CALL INIT_QUEUE(FOLDER_Q1,FOLDER1_COM) FOLDER_Q = FOLDER_Q1 SUBSCRIBE = CLI$PRESENT('SUBSCRIBE') IF (SUBSCRIBE) THEN CALL NEWS_GET_SUBSCRIBE(0,F1_END) SUBNUM = 1 CALL OPEN_BULLNEWS_SHARED ELSE CALL OPEN_BULLFOLDER_SHARED END IF NUM_FOLDERS = 0 IER = 0 DO WHILE (IER.EQ.0) ! Copy all bulletins from file IF (SUBSCRIBE) THEN IER = 1 DO WHILE (SUBNUM.NE.0.AND.IER.NE.0) CALL NEWS_GET_SUBSCRIBE(SUBNUM,F1_END) IF (SUBNUM.NE.0) THEN CALL READ_FOLDER_FILE_KEYNUM_TEMP(SUBNUM,IER) IF (IER.NE.0) SUBNUM = -1 END IF END DO IF (SUBNUM.EQ.0) IER = 1 ELSE CALL READ_FOLDER_FILE_TEMP(IER) END IF IF (IER.EQ.0) THEN IF (BTEST(FOLDER1_FLAG,0).AND..NOT.SETPRV_PRIV()) THEN FOLDER1_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY)) & //FOLDER1 CALL CHECK_ACCESS & (FOLDER1_FILE(:TRIM(FOLDER1_FILE))//'.BULLFIL', & USERNAME,READ_ACCESS,-1) ELSE READ_ACCESS = 1 END IF IF (READ_ACCESS) THEN NUM_FOLDERS = NUM_FOLDERS + 1 CALL WRITE_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) END IF END IF END DO CALL CLOSE_BULLFOLDER ! We don't need file anymore FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header WRITE (6,1000) IF (SUBSCRIBE) THEN WRITE (6,1025) ELSE WRITE (6,1020) END IF DO J = 1,NUM_FOLDERS CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) IF (SUBSCRIBE) THEN WRITE (6,1035) FOLDER1_DESCRIP(:72),F1_NBULL ELSE WRITE (6,1030) FOLDER1,F1_NBULL, & FOLDER1_DESCRIP(:MIN(TRIM(FOLDER1_DESCRIP),46)) END IF END DO WRITE (6,1060) FOLDER_Q = FOLDER_Q1 ! Init queue pointer to header INDEX_COUNT = 2 DIR_COUNT = 0 READ_TAG = .FALSE. IF (CLI$PRESENT('MARKED')) READ_TAG = .TRUE. RETURN ELSE IF (INDEX_COUNT.EQ.2) THEN IF (DIR_COUNT.LE.0) THEN F1_NBULL = 0 DO WHILE (NUM_FOLDERS.GT.0.AND.F1_NBULL.EQ.0) NUM_FOLDERS = NUM_FOLDERS - 1 CALL READ_QUEUE(%VAL(FOLDER_Q),FOLDER_Q,FOLDER1_COM) IF (F1_NBULL.GT.0) THEN FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) IF (.NOT.IER) F1_NBULL = 0 END IF END DO IF (F1_NBULL.EQ.0) THEN WRITE (6,1050) INDEX_COUNT = 0 RETURN END IF END IF IF (READ_TAG) THEN CALL GET_FIRST_TAG(FOLDER_NUMBER,IER,BULL_POINT) END IF CALL DIRECTORY(DIR_COUNT) IF (DIR_COUNT.GT.0) RETURN IF (NUM_FOLDERS.GT.0) THEN WRITE (6,1040) ELSE INDEX_COUNT = 0 END IF END IF RETURN 1000 FORMAT (' The following folders are present'/) 1020 FORMAT (' Name Count Description'/) 1025 FORMAT (' Name',70X,'Count'/) 1030 FORMAT (1X,A,1X,I6,1X,A) 1035 FORMAT (1X,A,1X,I6) 1040 FORMAT (' Type Return to continue to the next folder...') 1050 FORMAT (' End of folder search.') 1060 FORMAT (' Type Return to continue...') END SUBROUTINE SHOW_USER C C SUBROUTINE SHOW_USER C C FUNCTION: Shows information for specified users. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' COMMON /POINT/ BULL_POINT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER COMMON /CTRLC_FLAG/ FLAG DIMENSION NOLOGIN_BTIM(2),START_BTIM(2) CHARACTER DATETIME*17 DIMENSION LAST(2,FOLDER_MAX) INTEGER*2 LAST2(4,FOLDER_MAX) EQUIVALENCE (LAST,LAST2) ALL = CLI$PRESENT('NOLOGIN').OR.CLI$PRESENT('ALL') & .OR.CLI$PRESENT('LOGIN') SETPRV = SETPRV_PRIV() ! SETPRV_PRIV rewrites TEMP_USER IF (.NOT.ALL) THEN IER = CLI$GET_VALUE('USERNAME',TEMP_USER) IF (.NOT.IER) TEMP_USER = USERNAME END IF IF (.NOT.SETPRV.AND.(ALL.OR.USERNAME.NE.TEMP_USER)) THEN WRITE (6,'('' ERROR: No privs to use command.'')') RETURN END IF CALL SYS_BINTIM('5-NOV-2956 00:00:00.00',NOLOGIN_BTIM) FOLDER_PRESENT = CLI$PRESENT('FOLDER') IF (FOLDER_PRESENT) THEN IER = CLI$GET_VALUE('FOLDER',FOLDER1_NAME) IF (.NOT.IER) FOLDER1_NAME = FOLDER_NAME NEWS = INDEX(FOLDER1_NAME,'.').GT.0.OR.(FOLDER1_NAME(:1) & .GE.'a'.AND.FOLDER1_NAME(:1).LE.'z') IF (.NOT.NEWS) THEN CALL OPEN_BULLFOLDER_SHARED ELSE CALL OPEN_BULLNEWS_SHARED CALL LOWERCASE(FOLDER1_NAME) END IF CALL READ_FOLDER_FILE_KEYNAME_TEMP & (FOLDER1_NAME(:TRIM(FOLDER1_NAME)),IER) CALL CLOSE_BULLFOLDER IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Folder not found.'')') RETURN END IF END IF SINCE = CLI$PRESENT('SINCE').OR.CLI$PRESENT('START') IF (CLI$GET_VALUE('SINCE',BULL_PARAMETER,LEN_P)) THEN IF (.NOT.NEWS) THEN IER = SYS_BINTIM(BULL_PARAMETER,START_BTIM) IF (.NOT.IER) THEN WRITE (6,'('' ERROR: Invalid date specified.'')') RETURN END IF ELSE WRITE (6,'('' ERROR: /SINCE not valid with NEWS group.'')') RETURN END IF ELSE IF (CLI$GET_VALUE('START',BULL_PARAMETER,LEN_P)) THEN IF (NEWS) THEN IER = OTS$CVT_TI_L(BULL_PARAMETER(:LEN_P), & STARTMSG,,%VAL(1)) IF (.NOT.IER) THEN WRITE (6,'('' ERROR: Invalid number specified.'')') RETURN END IF ELSE WRITE (6,'('' ERROR: /START not valid with folder.'')') RETURN END IF ELSE IF (SINCE) THEN IF (BULL_POINT.EQ.0) THEN WRITE (6,'('' ERROR: No current message.'')') RETURN ELSE IF (NEWS) THEN STARTMSG = BULL_POINT ELSE START_BTIM(1) = MSG_BTIM(1) START_BTIM(2) = MSG_BTIM(2) END IF ELSE IF (.NOT.NEWS) THEN CALL SYS_BINTIM('6-NOV-1956 00:00:00.00',START_BTIM) ELSE STARTMSG = 1 END IF CALL DISABLE_CTRL CALL DECLARE_CTRLC_AST IF (FOLDER_PRESENT) THEN CALL OPEN_BULLINF_SHARED IER = 0 DO WHILE (IER.EQ.0.AND.FLAG.NE.1) IF (ALL) THEN DO WHILE (REC_LOCK(IER)) READ (9,IOSTAT=IER) TEMP_USER,LAST END DO ELSE IF (NEWS) THEN LU = TRIM(TEMP_USER) TEMP_USER(LU:LU) = CHAR(128.OR.ICHAR(TEMP_USER(LU:LU))) IF (LU.GT.1) THEN TEMP_USER(LU-1:LU-1) = & CHAR(128.OR.ICHAR(TEMP_USER(LU-1:LU-1))) ELSE TEMP_USER(2:2) = CHAR(128.OR.ICHAR(TEMP_USER(2:2))) END IF END IF DO WHILE (REC_LOCK(IER)) READ (9,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER,LAST END DO END IF UNLOCK 9 IF (IER.EQ.0) THEN LU = TRIM(TEMP_USER) I = MAX(LU,2) DO WHILE (I.GT.0.AND..NOT.BTEST(ICHAR(TEMP_USER(I:I)),7)) I = I - 1 END DO IF (NEWS.AND.I.GE.LU.AND.I.NE.1.AND. & BTEST(ICHAR(TEMP_USER(I-1:I-1)),7)) THEN TEMP_USER(I:I) = CHAR(ICHAR(TEMP_USER(I:I)).AND.127) TEMP_USER(I-1:I-1) = & CHAR(ICHAR(TEMP_USER(I-1:I-1)).AND.127) I = 0 NEWSMSG = 1 DO WHILE (LAST2(1,NEWSMSG).NE.NEWS_FOLDER1_NUMBER & .AND.NEWSMSG.LE.FOLDER_MAX) NEWSMSG = NEWSMSG + 1 END DO IF (NEWSMSG.LE.FOLDER_MAX) THEN FOUND = LAST(2,NEWSMSG).GE.STARTMSG ELSE FOUND = .FALSE. END IF ELSE IF (.NOT.NEWS.AND.I.EQ.0) THEN FOUND = COMPARE_BTIM & (START_BTIM,LAST(1,FOLDER1_NUMBER+1)).LE.0 ELSE FOUND = .FALSE. END IF IF (FOUND.AND.NEWS) THEN WRITE (6,'(1X,A,'' latest message read '', & I,''.'')') & TEMP_USER(:TRIM(TEMP_USER)),LAST(2,NEWSMSG) ELSE IF (FOUND) THEN CALL SYS$ASCTIM(,DATETIME,LAST(1,FOLDER1_NUMBER+1),) WRITE (6,'(1X,A,'' latest message read '',A,''.'')') & TEMP_USER(:TRIM(TEMP_USER)),DATETIME ELSE IF (.NOT.ALL) THEN WRITE (6,'('' User has never read or not subscribed'', & '' to specified folder.'')') END IF END IF IF (.NOT.ALL) THEN IF (IER.NE.0) THEN WRITE (6,'('' User info does not exist.'')') END IF IER = 2 END IF END DO CALL CLOSE_BULLINF ELSE IF (.NOT.ALL) THEN CALL OPEN_BULLUSER_SHARED CALL READ_USER_FILE_KEYNAME(TEMP_USER,IER) IF (IER.EQ.0) THEN IF (COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM).GE.0) THEN WRITE (6,'('' NOLOGIN set for specified user.'')') ELSE CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) WRITE (6,'('' User last logged in at '',A,''.'')') & DATETIME END IF ELSE WRITE (6,'('' Entry for specified user not found.'')') END IF CALL CLOSE_BULLUSER ELSE CALL OPEN_BULLUSER_SHARED CALL READ_USER_FILE(IER) DO WHILE (IER.EQ.0.AND.FLAG.NE.1) CALL READ_USER_FILE(IER) IF (IER.EQ.0.AND.TEMP_USER(:1).NE.':'.AND. & TEMP_USER(:1).NE.'*') THEN IER1 = COMPARE_BTIM(LOGIN_BTIM,NOLOGIN_BTIM) IF (.NOT.CLI$PRESENT('LOGIN').AND.IER1.GE.0) THEN WRITE (6,'('' NOLOGIN set for '',A,''.'')') & TEMP_USER(:TRIM(TEMP_USER)) ELSE IF (.NOT.CLI$PRESENT('NOLOGIN').AND.IER1.LT.0.AND. & COMPARE_BTIM(START_BTIM,LOGIN_BTIM).LE.0) THEN CALL SYS$ASCTIM(,DATETIME,LOGIN_BTIM,) WRITE (6,'(1X,A,'' last logged in at '',A,''.'')') & TEMP_USER(:TRIM(TEMP_USER)),DATETIME END IF END IF END DO CALL CLOSE_BULLUSER END IF CALL CANCEL_CTRLC_AST CALL ENABLE_CTRL RETURN END SUBROUTINE INIT_MESSAGE_ADD(IN_FOLDER,IN_FROM,IN_DESCRIP,IER) C C SUBROUTINE INIT_MESSAGE_ADD C C FUNCTION: Opens specified folder in order to add message. C C INPUTS: C IN_FOLDER - Character string containing folder name C IN_FROM - Character string containing name of owner of message. C If empty, the message is searched for either a C Reply-to: field or a From: field. If none, then C the owner of the process is used. If IN_FROM C ends with a %, it is assumed that it is simply C the prefix that should be when responding to the C address via MAIL. I.e. the PMDF interface sends C IN%, so when the From: field is found, the message C owner becomes IN%"from-address". C IN_DESCRIP - Character string containing subject of message. C If empty, the message is searched for a line C which starts with "Subj:" or "Subject:". C OUTPUTS: C IER - Error status. True if properly connected to folder. C False if folder not found. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLFILES.INC' INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' COMMON /BCP/ BULLCP LOGICAL BULLCP COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO CHARACTER*12 PROTOCOL DATA LPRO/0/ COMMON /DIGEST/ LDESCR,FIRST_BREAK CHARACTER*(*) IN_FOLDER,IN_FROM,IN_DESCRIP COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP COMMON /MAIN_HEADER_INFO/ INEXDATE CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP COMMON /TEXT_PRESENT/ TEXT COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(LINE_LENGTH) OLD_BUFFER COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM DATA OLD_BUFFER_FROM /.FALSE./ BULLCP = 1 ! Inhibit folder cleanup subprocess CALL OPEN_BULLFOLDER ! Get folder file CALL READ_FOLDER_FILE_KEYNAME(IN_FOLDER(:TRIM(IN_FOLDER)),IER) CALL CLOSE_BULLFOLDER IF (IER.NE.0) THEN CALL ERRSNS(IDUMMY,IER) RETURN ELSE IER = 1 END IF ENTRY INIT_MESSAGE_ADD_BBOARD(IN_FROM,IN_DESCRIP,IER) TEXT = .FALSE. ! No text written, as of yet FIRST_BREAK = .TRUE. IF (FOLDER_NUMBER.EQ.0) THEN ! If GENERAL folder FOLDER_SET = .FALSE. ! indicate it ELSE ! Else it's another folder FOLDER_SET = .TRUE. ! indicate it END IF FOLDER_FILE = FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))// & FOLDER ! set folder file names ENTRY INIT_MESSAGE_ADD_DIGEST(IN_FROM,IN_DESCRIP,IER) CALL OPEN_BULLDIR ! Open directory file CALL OPEN_BULLFIL ! Open data file CALL READDIR(0,IER1) ! Get NBLOCK IF (IER1.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 NBLOCK = NBLOCK + 1 LENGTH = NBLOCK ! Initialize line count LEN_FROM = TRIM(IN_FROM) IF (IN_FROM(LEN_FROM:LEN_FROM).EQ.'%') THEN ! Just protocol PROTOCOL = IN_FROM(:LEN_FROM)//'"' LPRO = LEN_FROM + 1 LEN_FROM = 0 END IF IF (LEN_FROM.GT.0) THEN INFROM = IN_FROM IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN CALL STORE_FROM(INFROM,LEN_FROM) ELSE IF (INDEX(INFROM,'%"').GT.0) THEN ! Store any protocol LPRO = INDEX(INFROM,'%"') + 1 PROTOCOL = INFROM(:LPRO) END IF LEN_DESCRP = TRIM(IN_DESCRIP) IF (LEN_DESCRP.GT.0) THEN INDESCRIP = IN_DESCRIP IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) END IF ELSE DESCRIP = ' ' END IF ELSE OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR', & FORM='FORMATTED',RECL=LINE_LENGTH,IOSTAT=IER1) IF (IER1.NE.0) THEN OPEN (UNIT=3,STATUS='SCRATCH',FILE='BULL.SCR', & FORM='FORMATTED',RECL=LINE_LENGTH) END IF SAVE_IN_DESCRIP = IN_DESCRIP SAVE_IN_FROM = ' ' END IF OLD_BUFFER = ' ' OLD_BUFFER_FROM = .FALSE. INEXDATE = .FALSE. RETURN END SUBROUTINE WRITEOUT_STORED CHARACTER*255 BUFFER REWIND (UNIT=3) IER = 0 DO WHILE (IER.EQ.0) READ (3,'(A)',IOSTAT=IER) BUFFER IF (IER.EQ.0) THEN CALL WRITE_MESSAGE_LINE(BUFFER) END IF END DO CLOSE (UNIT=3) RETURN END SUBROUTINE WRITE_MESSAGE_LINE(BUFFER) C C SUBROUTINE WRITE_MESSAGE_LINE C C FUNCTION: Writes one line of message into folder. C C INPUTS: C BUFFER - Character string containing line to be put into message. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO CHARACTER*12 PROTOCOL COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP COMMON /MAIN_HEADER_INFO/ INEXDATE CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP COMMON /DIGEST/ LDESCR,FIRST_BREAK DATA FIRST_BREAK/.TRUE./ COMMON /TEXT_PRESENT/ TEXT COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM CHARACTER*(*) BUFFER COMMON /LAST_BUFFER/ OLD_BUFFER CHARACTER*(LINE_LENGTH) OLD_BUFFER COMMON /OLD_BUFFER_FROM/ OLD_BUFFER_FROM DATA OLD_BUFFER_FROM /.FALSE./ COMMON /DATE/ DATE_LINE CHARACTER*(LINE_LENGTH) DATE_LINE CHARACTER*23 TODAY LEN_BUFFER = TRIM(BUFFER) IF (LEN_FROM.EQ.0) THEN WRITE (3,'(A)') BUFFER(:LEN_BUFFER) IF (OLD_BUFFER_FROM.AND.BUFFER(:1).EQ.' ') THEN SAVE_IN_FROM = & SAVE_IN_FROM(:TRIM(SAVE_IN_FROM))//BUFFER OLD_BUFFER_FROM = .FALSE. ELSE IF (BUFFER(:5).EQ.'From:') THEN IF (LEN_BUFFER.GE.7) SAVE_IN_FROM = BUFFER(7:) OLD_BUFFER_FROM = .TRUE. RETURN ELSE IF (BUFFER(:9).EQ.'Subject: ') THEN LDESCR = LEN_BUFFER - 9 INDESCRIP = BUFFER(10:) ELSE IF (BUFFER(:9).EQ.'Reply-to:'.AND.SAVE_IN_FROM.EQ.' ') THEN IF (LEN_BUFFER.GE.11) SAVE_IN_FROM = BUFFER(11:) OLD_BUFFER_FROM = .TRUE. RETURN ELSE IF (LEN_BUFFER.EQ.0) THEN IF (SAVE_IN_FROM.EQ.' ') CALL GETUSER(SAVE_IN_FROM) LEN_FROM = TRIM(SAVE_IN_FROM) IF (LEN_FROM.GT.0) THEN OLD_BUFFER_FROM = .FALSE. INFROM = SAVE_IN_FROM IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN CALL STORE_FROM(INFROM,LEN_FROM) ELSE IF (INDEX(INFROM,'%"').GT.0) THEN LPRO = INDEX(INFROM,'%"') + 1 PROTOCOL = INFROM(:LPRO) END IF IF (LDESCR.GT.0) THEN LEN_DESCRP = LDESCR CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) ELSE LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) IF (LEN_DESCRP.GT.0) THEN INDESCRIP = SAVE_IN_DESCRIP IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) END IF ELSE DESCRIP = ' ' END IF END IF CALL WRITEOUT_STORED END IF END IF OLD_BUFFER_FROM = .FALSE. RETURN END IF IF (BTEST(FOLDER_FLAG,5)) THEN IF (INDEX(BUFFER,'-------------').EQ.1) THEN BREAK = .TRUE. DO I=1,LEN_BUFFER IF (BUFFER(I:I).NE.'-') BREAK = .FALSE. END DO ELSE BREAK = .FALSE. END IF IF (BREAK) THEN IF (.NOT.FIRST_BREAK) THEN CALL FINISH_MESSAGE_ADD CALL INIT_MESSAGE_ADD_DIGEST(INFROM,INDESCRIP,IER) ELSE FIRST_BREAK = .FALSE. END IF LFROM = 0 LDESCR = 0 RETURN ELSE IF (.NOT.FIRST_BREAK) THEN IF (LDESCR.EQ.0) THEN IF (BUFFER(:9).EQ.'Subject: ') THEN LDESCR = LEN_BUFFER - 9 CALL STORE_DESCRP(BUFFER(10:),LDESCR) IF (LFROM.EQ.0) THEN LFROM = LEN_FROM CALL STORE_FROM(INFROM,LFROM) END IF ELSE IF (BUFFER(:6).EQ.'From: ') THEN LFROM = LEN_BUFFER - 6 IF (LFROM.LE.0) THEN LFROM = TRIM(SAVE_IN_FROM) IF (LPRO.GT.0) THEN LFROM = LFROM + LPRO + 1 CALL STORE_FROM(PROTOCOL(:LPRO)// & SAVE_IN_FROM//'"',LFROM) ELSE CALL STORE_FROM(SAVE_IN_FROM,LFROM) END IF ELSE IF (LPRO.GT.0) THEN LFROM = LFROM + LPRO + 1 CALL STORE_FROM(PROTOCOL(:LPRO)// & BUFFER(7:LEN_BUFFER)//'"',LFROM) ELSE CALL STORE_FROM(BUFFER(7:),LFROM) END IF END IF RETURN END IF ELSE RETURN END IF END IF IF (LEN_BUFFER.EQ.0) THEN ! If empty line CALL STORE_BULL(1,' ',NBLOCK) ! just store one space ELSE IF (LEN_DESCRP.EQ.0) THEN IF (BUFFER(:9).EQ.'Subject: ') THEN DESCRIP = BUFFER(INDEX(BUFFER,' ')+1:) LEN_DESCRP = LEN_BUFFER END IF END IF IF (.NOT.INEXDATE) THEN IF (BUFFER(:9).EQ.'Expires: '.OR. & BUFFER(:11).EQ.'X-Expires: ') THEN I = INDEX(BUFFER,' ')+1 NODATE = .FALSE. DO J=I,LEN_BUFFER IF (BUFFER(J:J).EQ.','.OR.BUFFER(J:J).EQ.'-') THEN BUFFER(J:J) = ' ' END IF END DO CALL STR$UPCASE(BUFFER(I:),BUFFER(I:)) NODATE = .TRUE. I = INDEX(BUFFER,' ')+1 EXDATE(3:3) = '-' EXDATE(7:7) = '-' DO WHILE (I.LE.LEN_BUFFER) IF (BUFFER(I:I).GE.'0'.AND.BUFFER(I:I).LE.'9') THEN IF (NODATE) THEN IF (INDEX(BUFFER(I:),' ').EQ.2) THEN EXDATE(1:2) = '0'//BUFFER(I:I) I = I + 1 ELSE EXDATE(1:2) = BUFFER(I:I+1) I = I + 2 END IF NODATE = .FALSE. ELSE IF (LEN_BUFFER-I.EQ.1.OR. & INDEX(BUFFER(I:),' ').EQ.3) THEN ! No century? IER = SYS$ASCTIM(,TODAY,,) ! Get today's date YEAR = INDEX(TODAY(6:),'-') EXDATE(8:) = TODAY(6+YEAR:7+YEAR)//BUFFER(I:I+1) I = I + 2 ELSE EXDATE(8:) = BUFFER(I:I+3) I = I + 4 END IF END IF ELSE IF (BUFFER(I:I).GE.'A'.AND.BUFFER(I:I).LE.'Z') THEN EXDATE(4:6) = BUFFER(I:I+2) I = I + 3 ELSE I = I + 1 END IF END DO INEXDATE = .TRUE. END IF END IF CALL STORE_BULL(MIN(LEN_BUFFER,LINE_LENGTH),BUFFER,NBLOCK) TEXT = .TRUE. END IF RETURN END SUBROUTINE FINISH_MESSAGE_ADD C C SUBROUTINE FINISH_MESSAGE_ADD C C FUNCTION: Writes message entry into directory file and closes folder C C NOTE: Only should be run if INIT_MESSAGE_ADD was successful. C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /DIGEST/ LDESCR,FIRST_BREAK COMMON /TEXT_PRESENT/ TEXT COMMON /MAIN_HEADER_INFO/ INFROM,INDESCRIP,LEN_FROM,LEN_DESCRP COMMON /MAIN_HEADER_INFO/ INEXDATE CHARACTER*(LINE_LENGTH) INFROM,INDESCRIP COMMON /SAVE_IN/ SAVE_IN_DESCRIP,SAVE_IN_FROM CHARACTER*(LINE_LENGTH) SAVE_IN_DESCRIP,SAVE_IN_FROM CHARACTER*23 TODAY DIMENSION BIN_EXTIME(2) IF (LEN_FROM.EQ.0) THEN CALL GETUSER(FROM) INFROM = FROM LEN_FROM = TRIM(INFROM) LEN_DESCRP = TRIM(SAVE_IN_DESCRIP) IF (LEN_DESCRP.GT.0) THEN INDESCRIP = SAVE_IN_DESCRIP IF (.NOT.BTEST(FOLDER_FLAG,5)) THEN CALL STORE_DESCRP(INDESCRIP,LEN_DESCRP) END IF ELSE DESCRIP = ' ' END IF CALL WRITEOUT_STORED END IF CALL FLUSH_BULL(NBLOCK) CALL CLOSE_BULLFIL ! Finished adding bulletin IF ((BTEST(FOLDER_FLAG,5).AND.LDESCR.EQ.0).OR. ! End of digest msg & .NOT.TEXT) THEN ! or no message text found CALL CLOSE_BULLDIR ! then don't add message entry RETURN END IF EXTIME = '00:00:00.00' IF (INEXDATE) THEN IER = SYS_BINTIM(EXDATE//' '//EXTIME,BIN_EXTIME) IF (IER) THEN ! If good date format IER = SYS$ASCTIM(,TODAY,,) ! Get today's date IER = COMPARE_DATE(EXDATE,TODAY(:11)) ! Compare date with today's IF ((IER.GT.F_EXPIRE_LIMIT.AND.F_EXPIRE_LIMIT.GT.0) ! Too great? & .OR.IER.LE.0) THEN ! or expiration date not future INEXDATE = .FALSE. ! Don't use it END IF ELSE INEXDATE = .FALSE. ! Don't use it END IF END IF IF (.NOT.INEXDATE) THEN IF (FOLDER_BBEXPIRE.EQ.-1) THEN ! Folder has expiration time? EXDATE = '5-NOV-2000' ! no, so set date far in future SYSTEM = 2 ! indicate permanent message ELSE ! Else set expiration date CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) SYSTEM = 0 END IF END IF LENGTH = NBLOCK - LENGTH + 1 ! Number of records CALL ADD_ENTRY ! Add the new directory entry CALL CLOSE_BULLDIR ! Totally finished with add CALL UPDATE_FOLDER RETURN END SUBROUTINE STORE_FROM(IFROM,LEN_INFROM) IMPLICIT INTEGER (A-Z) COMMON /MAIL_PROTOCOL/ PROTOCOL,LPRO CHARACTER*12 PROTOCOL INCLUDE 'BULLDIR.INC' CHARACTER*(*) IFROM CHARACTER*(LINE_LENGTH) INFROM INFROM = IFROM IF (LPRO.GT.0) THEN ! Protocol present? I = INDEX(INFROM,'%"') + 2 ! Make usable for VMS MAIL IF (I.EQ.2) THEN INFROM = PROTOCOL(:LPRO)//INFROM(:LEN_INFROM)//'"' I = LPRO + 1 LEN_INFROM = LEN_INFROM + LPRO + 1 END IF DO WHILE (I.LT.LEN_INFROM) IF (INFROM(I:I).EQ.'"') THEN INFROM(I:I) = '''' ELSE IF (INFROM(I:I).EQ.'\') THEN INFROM(I+1:) = '\'//INFROM(I+1:) LEN_INFROM = LEN_INFROM + 1 I = I + 1 ELSE IF (INFROM(I:I).EQ.'''') THEN INFROM(I:) = '\s'//INFROM(I+1:) LEN_INFROM = LEN_INFROM + 1 I = I + 2 END IF I = I + 1 END DO END IF DO I=1,LEN_INFROM ! Remove control characters IF (INFROM(I:I).LT.' ') INFROM(I:I) = ' ' END DO DO WHILE (LEN_INFROM.GT.0.AND.INFROM(:1).EQ.' ') INFROM = INFROM(2:) LEN_INFROM = LEN_INFROM - 1 END DO TWO_SPACE = INDEX(INFROM,' ') DO WHILE (TWO_SPACE.GT.0.AND.TWO_SPACE.LT.LEN_INFROM) INFROM = INFROM(:TWO_SPACE)//INFROM(TWO_SPACE+2:) LEN_INFROM = LEN_INFROM - 1 TWO_SPACE = INDEX(INFROM,' ') END DO CALL STORE_BULL(6+LEN_INFROM,'From: '//INFROM(:LEN_INFROM), & NBLOCK) IF (INDEX(INFROM,'%"').GT.0) ! Strip off protocol program & INFROM = INFROM(INDEX(INFROM,'%"')+2:) IF (INDEX(INFROM,'::').GT.0) ! Strip off node name & INFROM = INFROM(INDEX(INFROM,'::')+2:) ! I.e. HOST::USER CALL GET_FROM(INFROM,LEN_INFROM) RETURN END SUBROUTINE GET_FROM(INFROM,LEN_INFROM) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' CHARACTER*(*) INFROM DO WHILE (INDEX(INFROM,'!').GT.0.AND. ! Unix address go backwards. & INDEX(INFROM,'!').LT.INDEX(INFROM,'@')) INFROM = INFROM(INDEX(INFROM,'!')+1:) ! I.e. host!user END DO DO WHILE (INDEX(INFROM,'<').GT.0.AND. ! Name may be of form & INDEX(INFROM,'@').GT.INDEX(INFROM,'<')) INFROM = INFROM(INDEX(INFROM,'<')+1:)! personal-name END DO DO WHILE (INDEX(INFROM,'(').GT.0.AND. ! personal-name (net-name) & INDEX(INFROM,'@').GT.INDEX(INFROM,'(')) INFROM = INFROM(INDEX(INFROM,'(')+1:) END DO I = 1 ! Trim username to start at first alpha character DO WHILE (I.LE.LEN_INFROM.AND.(INFROM(I:I).EQ.' '.OR. & INFROM(I:I).EQ.'%'.OR.INFROM(I:I).EQ.'.'.OR. & INFROM(I:I).EQ.'@'.OR.INFROM(I:I).EQ.'<'.OR. & INFROM(I:I).EQ.'"'.OR.INFROM(I:I).EQ.'''')) I = I + 1 END DO INFROM = INFROM(I:) I = 1 ! Trim username to end at a alpha character DO WHILE (I.LE.12.AND.INFROM(I:I).NE.' '.AND. & INFROM(I:I).NE.'%'.AND.INFROM(I:I).NE.'.'.AND. & INFROM(I:I).NE.'@'.AND.INFROM(I:I).NE.'<'.AND. & INFROM(I:I).NE.'"'.AND.INFROM(I:I).NE.'''') I = I + 1 END DO FROM = INFROM(:I-1) DO J=2,I-1 IF ((FROM(J:J).GE.'A'.AND.FROM(J:J).LE.'Z').AND. & ((FROM(J-1:J-1).GE.'A'.AND.FROM(J-1:J-1).LE.'Z').OR. & (FROM(J-1:J-1).GE.'a'.AND.FROM(J-1:J-1).LE.'z'))) THEN FROM(J:J) = CHAR(ICHAR(FROM(J:J))-ICHAR('A')+ICHAR('a')) END IF END DO RETURN END SUBROUTINE STORE_DESCRP(INDESCRIP,LEN_DESCRP) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLDIR.INC' CHARACTER*(*) INDESCRIP CALL CONVERT_TABS(INDESCRIP,LEN_DESCRP) DO I=1,LEN_DESCRP ! Remove control characters IF (INDESCRIP(I:I).LT.' ') INDESCRIP(I:I) = ' ' END DO DO WHILE (LEN_DESCRP.GT.0.AND.INDESCRIP(:1).EQ.' ') INDESCRIP = INDESCRIP(2:) LEN_DESCRP = LEN_DESCRP - 1 END DO IF (LEN_DESCRP.GT.LEN(DESCRIP)) THEN ! Is length > allowable subject length? CALL STORE_BULL(6+LEN_DESCRP,'Subj: '// & INDESCRIP(:LEN_DESCRP),NBLOCK) END IF DESCRIP = INDESCRIP(:MIN(LEN_DESCRP,LEN(DESCRIP))) RETURN END SUBROUTINE STRIP_HEADER(BUFFER,BLEN,IER) C C SUBROUTINE STRIP_HEADER C C FUNCTION: Indicates whether line is part of mail message header. C C INPUTS: C BUFFER - Character string containing input line of message. C BLEN - Length of character string. If = 0, initialize subroutine. C C OUTPUTS: C IER - If true, line should be stripped. Else, end of header. C IMPLICIT INTEGER (A - Z) INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' COMMON /DATE/ DATE_LINE CHARACTER*(LINE_LENGTH) DATE_LINE COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT CHARACTER*(*) BUFFER IF (TRIM(BUFFER).EQ.0) THEN ! If STRIP not set for folder or empty line IER = .FALSE. CONT_LINE = .FALSE. RETURN END IF IF (BLEN.EQ.0) THEN DATE_LINE = ' ' CONT_LINE = .FALSE. END IF IER = .TRUE. IF (CONT_LINE.AND.(BUFFER(:1).EQ.' '.OR. ! If line is continuation & BUFFER(:1).EQ.CHAR(9))) RETURN ! of previous header line I = 1 DO WHILE (I.LE.BLEN.AND.BUFFER(I:I).NE.' ') IF (BUFFER(I:I).EQ.':') THEN ! Header line found CONT_LINE = .TRUE. ! Next line might be continuation IF (REMOTE_SET.NE.3.AND.BUFFER(:5).EQ.'Date:') THEN DATE_LINE = 'Message sent'//BUFFER(5:BLEN) IF (DATE_LINE(TRIM(DATE_LINE):).NE.'.') THEN DATE_LINE(TRIM(DATE_LINE)+1:) = '.' END IF END IF RETURN ELSE I = I + 1 END IF END DO IER = .FALSE. CONT_LINE = .FALSE. RETURN END