From:	SMTP%"BULLETIN@PFC.MIT.EDU" 19-AUG-1994 17:27:51.32
To:	EVERHART
CC:	
Subj:	BULLETIN4.FOR

Date: Fri, 19 Aug 1994 17:25:46 -0400 (EDT)
From: BULLETIN@PFC.MIT.EDU
To:   EVERHART@arisia.gce.com
Message-Id: <940819172546.21438991@PFC.MIT.EDU>
Subject: BULLETIN4.FOR

C
C  BULLETIN4.FOR, Version 8/10/94
C  Purpose: Contains subroutines for the BULLETIN utility program.
C  Environment: VAX/VMS
C  Programmer: Mark R. London
C
C  Copyright (c) 1990
C  Property of Massachusetts Institute of Technology, Cambridge MA 02139.
C  This program cannot be copied or distributed in any form for non-MIT
C  use without specific written approval of MIT Plasma Fusion Center
C  Management.
C
C
C  SUBROUTINE ITMLST_SUBS
C
C  FUNCTION:
C	A set of routines to easily create item lists.  It allows one
C  to easily create item lists without the need for declaring arrays
C  or itemlist size.  Thus, the code can be easily changed to add or
C  delete item list codes.
C
C  Here is an example of how to use the routines (prints file to a queue):
C
C	CALL INIT_ITMLST	! Initialize item list
C				! Now add items to list
C	CALL ADD_2_ITMLST(LEN,SJC$_FILE_SPECIFICATION,%LOC(FILENAME))
C	CALL ADD_2_ITMLST(9,SJC$_QUEUE,%LOC(QUEUE))
C	CALL END_ITMLST(SNDJBC_ITMLST)	! Get address of itemlist
C	IER = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,%VAL(SNDJBC_ITMLST),IOSB,,)
C
	SUBROUTINE ITMLST_SUBS

	IMPLICIT INTEGER (A-Z)

	DATA SAVE_ITMLST_ADDRESS/0/,NUM_ITEMS/0/,QUEUE_HEADER/0/

	ENTRY INIT_ITMLST

	IF (QUEUE_HEADER.EQ.0) THEN	! First time INIT_ITMLST ever called?
	   CALL LIB$GET_VM(8,QUEUE_HEADER)  ! Yes, create queue header pointer
	   CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER))	! Zero out header
	   CALL LIB$MOVC3(4,0,%VAL(QUEUE_HEADER+4))	! Zero out header
	ELSE IF (SAVE_ITMLST_ADDRESS.GT.0) THEN	! Clean out old item list
	   CALL LIB$FREE_VM((NUM_ITEMS+1)*12,SAVE_ITMLST_ADDRESS)
	   NUM_ITEMS = 0		! Release old itemlist memory
	   SAVE_ITMLST_ADDRESS = 0
	ELSE				! ITMLST calls cannot be nested.
	   WRITE (6,'('' ERROR: INIT_ITMLST called before previous'',$)')
	   WRITE (6,'(''+ ITMLST terminated with END_ITMLST.'')')
	   CALL EXIT
	END IF

	RETURN


	ENTRY ADD_2_ITMLST(BUFLEN,CODE,BUFADR)
C
C  ITMLST entries are initially stored in a queue.  Each queue entry
C  needs 8 bytes for pointer + 12 bytes for itemlist info.
C
	CALL LIB$GET_VM(20,INPUT_ITMLST)	! Get memory for entry

	CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,0)
						! Store data in itemlist format
	CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER))
						! Insert entry into queue
	NUM_ITEMS = NUM_ITEMS + 1		! Increment item count

	RETURN


	ENTRY ADD_2_ITMLST_WITH_RET(BUFLEN,CODE,BUFADR,RETADR)
C
C  ITMLST entries are initially stored in a queue.  Each queue entry
C  needs 8 bytes for pointer + 12 bytes for itemlist info.
C
	CALL LIB$GET_VM(20,INPUT_ITMLST)	! Get memory for entry

	CALL STORE_ITMLST_ENTRY(%VAL(INPUT_ITMLST+8),BUFLEN,CODE,BUFADR,
     &							RETADR)
						! Store data in itemlist format
	CALL LIB$INSQTI(%VAL(INPUT_ITMLST),%VAL(QUEUE_HEADER))
						! Insert entry into queue
	NUM_ITEMS = NUM_ITEMS + 1		! Increment item count

	RETURN


	ENTRY END_ITMLST(ITMLST_ADDRESS)

	CALL LIB$GET_VM((NUM_ITEMS+1)*12,ITMLST_ADDRESS)
						! Get memory for itemlist
	SAVE_ITMLST_ADDRESS = ITMLST_ADDRESS	! Save address to remove memory

	DO I=1,NUM_ITEMS			! Place entries into itemlist
	   CALL LIB$REMQHI(%VAL(QUEUE_HEADER),INPUT_ITMLST)
	   CALL LIB$MOVC3(12,%VAL(INPUT_ITMLST+8),
     &		%VAL(ITMLST_ADDRESS+(I-1)*12))
	   CALL LIB$FREE_VM(20,INPUT_ITMLST)
	END DO

	CALL LIB$MOVC3(4,0,%VAL(ITMLST_ADDRESS+NUM_ITEMS*12))
					! Place terminating 0 at end of itemlist

	RETURN
	END



	SUBROUTINE STORE_ITMLST_ENTRY(INPUT_ITMLST,BUFLEN,CODE,BUFADR,
     &							RETADR)

	IMPLICIT INTEGER (A-Z)

	STRUCTURE /ITMLST/
	 UNION
	  MAP
	   INTEGER*2 BUFLEN,CODE
	   INTEGER BUFADR,RETADR
	  END MAP
	 END UNION
	END STRUCTURE

	RECORD /ITMLST/ INPUT_ITMLST(1)

	INPUT_ITMLST(1).BUFLEN = BUFLEN
	INPUT_ITMLST(1).CODE = CODE
	INPUT_ITMLST(1).BUFADR = BUFADR
	INPUT_ITMLST(1).RETADR = RETADR

	RETURN
	END


	SUBROUTINE CLEANUP_LOGIN
C
C  SUBROUTINE CLEANUP_LOGIN
C
C  FUNCTION: Removes entry in user file of user that no longer exist.
C		It creates empty space for new user.
C
	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLUSER.INC'

	CHARACTER*12 LOGIN_USER

	CHARACTER TODAY*24

	DIMENSION TODAY_BTIM(2)

	MARK = SYS_TRNLNM_SYSTEM('BULL_MARK','DEFINED')

	CALL SYS$ASCTIM(,TODAY,,)		! Get the present time
	CALL SYS_BINTIM(TODAY,TODAY_BTIM)

	CALL OPEN_SYSUAF_SHARED

	LOGIN_USER = USERNAME
	READ (4,IOSTAT=IER1,KEYGT=USERNAME) USER_ENTRY	! Look forward one
	TEMP_USER = USERNAME
	USERNAME = LOGIN_USER
	DO WHILE (REC_LOCK(IER))
	   READ (8,KEY=TEMP_USER,IOSTAT=IER) TEMP_USER	! See if user exists
	END DO

	IF (IER.NE.0.AND.IER1.EQ.0.AND.TEMP_USER.NE.USER_HEADER_KEY) THEN
				! If no UAF entry and last login was
				! more than 6 months old, delete entry
	   IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN
	      DELETE(UNIT=4)			! Delete non-existant user
	      CALL OPEN_BULLINF
	      READ (9,KEY=TEMP_USER,IOSTAT=IER)
	      IF (IER.EQ.0) DELETE(UNIT=9)
	      LU = TRIM(TEMP_USER)
	      IF (MARK) CALL LIB$DELETE_FILE('BULL_MARK:'//
     &					TEMP_USER(:LU)//'.*MARK;*')
	      TEMP_USER(LU:LU) = CHAR(ICHAR(TEMP_USER(LU:LU)).OR.128)
	      READ (9,KEY=TEMP_USER,IOSTAT=IER)
	      IF (IER.EQ.0) DELETE(UNIT=9)
	      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
	      READ (9,KEY=TEMP_USER,IOSTAT=IER)
	      IF (IER.EQ.0) DELETE(UNIT=9)
	      CALL CLOSE_BULLINF
	   END IF
	END IF

	CALL CLOSE_SYSUAF			! All done...

	RETURN
	END


	SUBROUTINE TOTAL_CLEANUP_LOGIN
C
C  SUBROUTINE TOTAL_CLEANUP_LOGIN
C
C  FUNCTION: Removes all entries in user file of usesr that no longer exist
C
	IMPLICIT INTEGER (A-Z)

	INCLUDE 'BULLUSER.INC'

	COMMON /BULL_NOTIFY/ NOTIFY_REMOTE(FLONG)

	CHARACTER TODAY*24

	DIMENSION TODAY_BTIM(2)

	CALL SYS$ASCTIM(,TODAY,,)		! Get the present time
	CALL SYS_BINTIM(TODAY,TODAY_BTIM)

	MARK = SYS_TRNLNM_SYSTEM('BULL_MARK','DEFINED')

	CALL OPEN_SYSUAF_SHARED
	CALL OPEN_BULLUSER
	CALL OPEN_BULLINF

	TEMP_USER = USERNAME

	IER = 0

	DO WHILE (IER.EQ.0)			! Clean out BULLUSER.DAT
	   READ (4,IOSTAT=IER) USER_ENTRY
	   IF (IER.EQ.0.AND.USERNAME(:1).NE.'*'.AND.
     &	       USERNAME(:1).NE.':'.AND.
     &	       USERNAME.NE.USER_HEADER_KEY) THEN	! See if user exists
	      DO WHILE (REC_LOCK(IER))
	         READ (8,KEY=USERNAME,IOSTAT=IER)
	      END DO
	      IF (IER.NE.0) THEN 	! If no UAF entry and last login was
					! more than 6 months old, delete entry
		 IF (MINUTE_DIFF(TODAY_BTIM,LOGIN_BTIM).GT.6*30*24*60) THEN
	            DELETE (UNIT=4)
		    READ (9,KEY=USERNAME,IOSTAT=IER)
		    IF (IER.EQ.0) DELETE (UNIT=9)
	            LU = TRIM(USERNAME)
		    IF (MARK) CALL LIB$DELETE_FILE('BULL_MARK:'//
     &					USERNAME(:LU)//'.*MARK;*')
	            USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).OR.128)
		    READ (9,KEY=USERNAME,IOSTAT=IER)
		    IF (IER.EQ.0) DELETE (UNIT=9)
		    IF (LU.GT.1) THEN
		       USERNAME(LU-1:LU-1) = 
     &			 CHAR(128.OR.ICHAR(USERNAME(LU-1:LU-1)))
		    ELSE
		       USERNAME(2:2) = CHAR(128.OR.ICHAR(USERNAME(2:2)))
		    END IF
		    READ (9,KEY=USERNAME,IOSTAT=IER)
		    IF (IER.EQ.0) DELETE (UNIT=9)
		 END IF
		 IER = 0
	      ELSE
		 DO I=0,FOLDER_MAX-1
		    IF (TEST2(NOTIFY_FLAG,I)) THEN
		       CALL SET2(NOTIFY_REMOTE,I)
		    END IF
		 END DO
	      END IF
	   END IF
	END DO

	CALL CLOSE_SYSUAF			! All done...

	DO WHILE (REC_LOCK(IER))
	   READ (4,KEY='*NOTIFY',IOSTAT=IER) TEMP_USER
	END DO

	IF (IER.NE.0) THEN
	   WRITE (4,IOSTAT=IER) '*NOTIFY     ',NOTIFY_REMOTE9
	ELSE:
	   REWRITE (4,IOSTAT=IER) '*NOTIFY     ',NOTIFY_REMOTE 
	END IFu

	READ (9,KEYGT='            ',IOSTAT=IER) USERNAME

	DO WHILE (IER.EQ.0)			! Clean out BULLINF.DAT
	   LU = TRIM(USERNAME)M
	   USERNAME(LU:LU) = CHAR(ICHAR(USERNAME(LU:LU)).AND.127)
	   IF (LU.GT.1) THENo
	      USERNAME(LU-1:LU-1) = e
     &			 CHAR(127.AND.ICHAR(USERNAME(LU-1:LU-1)))
	   ELSE
	      USERNAME(2:2) = CHAR(127.AND.ICHAR(USERNAME(2:2)))e
	   END IF
	   READ (4,KEYEQ=USERNAME,IOSTAT=IER)
	   IF (IER.NE.0) DELETE (UNIT=9)n
	   READ (9,IOSTAT=IER) USERNAME
	END DO 

	CALL CLOSE_BULLINFt
	CALL CLOSE_BULLUSER

	USERNAME = TEMP_USER 

	RETURNM
	END


	SUBROUTINE COPY_BULL(INLUN,IBLOCK,OBLOCK,IER)
CO
C  SUBROUTINE COPY_BULLo
Cs
C  FUNCTION: To copy data to the bulletin file.i
Cc
C  INPUT:l
C	INLUN	-	Input logical unit numberr
C	IBLOCK	-	Input block number in input file to start atc
C	OBLOCK	-	Output block number in output file to start ats
C 
C  OUTPUT:
C	IER	-	If error in writing to bulletin, IER will be <> 0.
CI
C  NOTES:  Input file is accessed using sequential access.  This is 
C	to allow files which have variable records to be read.  TheA
C       bulletin file is assumed to be opened on logical unit 1.
CI

	IMPLICIT INTEGER (A - Z)i

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT

	COMMON /LAST_RECORD_WRITTEN/ OCOUNT

	INCLUDE 'BULLDIR.INC'

	IF (REMOTE_SET) THENT
	   CALL REMOTE_COPY_BULL(IER)
	   IF (IER.NE.0) CALL ERROR_AND_EXITT
	END IFI

	DO I=1,IBLOCK-1
	   READ(INLUN,'(A)')T
	END DOv

	OCOUNT = OBLOCK
	ICOUNT = IBLOCK

	NBLANK = 0s
	LENGTH = 0e
	DO WHILE (LENGTH.GE.0)L
	   ILEN = 0
	   DO WHILE (ILEN.EQ.0)
	      READ(INLUN,'(Q,A)',END=100) ILEN,INPUT_
	      ILEN = MIN(ILEN,TRIM(INPUT),LINE_LENGTH)S
	      IF (ILEN.GT.1.AND.ICHAR(INPUT(ILEN:ILEN)).EQ.10) THEN
		 INPUT(ILEN-1:ILEN-1) = CHAR(32)	! Remove imbedded
		 INPUT(ILEN:ILEN) = CHAR(32)	! CR/LFs at end of file._
		 ILEN = ILEN - 2
	      END IFl
	      IF (ILEN.GT.0) THEN
		 IF (ICOUNT.EQ.IBLOCK) THENc
		    IF (INPUT(:6).EQ.'From: ') THEN 
		       INPUT(:4) = 'FROM't
		    END IF
		 END IFA
		 ICOUNT = ICOUNT + 1
	      ELSE IF (ILEN.EQ.0.AND.ICOUNT.GT.IBLOCK) THEN
		 NBLANK = NBLANK + 1
	      END IFr
	   END DO
	   IF (NBLANK.GT.0) THENe
	      DO I=1,NBLANK
	         CALL STORE_BULL(1,' ',OCOUNT) 
	      END DON
	      LENGTH = LENGTH + NBLANK*2
	      NBLANK = 0T
	   END IF
	   CALL STORE_BULL(ILEN,INPUT,OCOUNT)
	   LENGTH = LENGTH + ILEN + 1
	END DOC

100	LENGTH = (LENGTH+127)/128,
	IF (LENGTH.EQ.0) THEN
	   IER = 1e
	ELSEt
	   IER = 0M
	END IFN

	CALL FLUSH_BULL(OCOUNT)

	RETURN
	END




	SUBROUTINE STORE_BULL(ILEN,INPUT,OCOUNT)F

	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLFOLDER.INC'i

	COMMON /STORE_POINT/ POINT 
	DATA POINT/-1/r

	CHARACTER INPUT*(*),OUTPUT*255f

	IF (POINT.EQ.-1) THEN
	   POINT = 0	
	   IF (BTEST(FOLDER_FLAG,12)) CALL STORE_BULL1(0,CHAR(0),OCOUNT)T
	END IFN

	IF (BTEST(FOLDER_FLAG,12)) THEN
	   CALL COMPRESS(INPUT(:ILEN),OUTPUT,OLEN)L
	   CALL STORE_BULL1(OLEN,OUTPUT,OCOUNT)
	ELSE)
	   CALL STORE_BULL1(ILEN,INPUT,OCOUNT)M
	END IFN

	RETURN1
	END




	SUBROUTINE STORE_BULL1(ILEN,INPUT,OCOUNT)

	IMPLICIT INTEGER (A-Z) 

	PARAMETER BRECLEN=128

	CHARACTER INPUT*(*),OUTPUT*256o

	COMMON /STORE_POINT/ POINTA

	IF (ILEN+POINT+1.GT.BRECLEN) THEN
	   IF (POINT.EQ.BRECLEN) THEN
	      CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT))
	      OUTPUT = CHAR(ILEN)//INPUTI
	      POINT = ILEN + 13
	   ELSE IF (POINT.EQ.BRECLEN-1) THENL
	      CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN))
	      OUTPUT = INPUTI
	      POINT = ILENS
	   ELSE
	      CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:POINT)//CHAR(ILEN)
     &		//INPUT(:BRECLEN-1-POINT))
	      OUTPUT = INPUT(BRECLEN-POINT:)C
	      POINT = ILEN - (BRECLEN-1-POINT)P
	   END IF
	   OCOUNT = OCOUNT + 1T
	   DO WHILE (POINT.GE.BRECLEN)E
	      CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN))
	      OCOUNT = OCOUNT + 1
	      OUTPUT = OUTPUT(BRECLEN+1:)
	      POINT = POINT - BRECLEN
	   END DO
	ELSEI
	   OUTPUT(POINT+1:) = CHAR(ILEN)//INPUT(:ILEN)U
	   POINT = POINT + ILEN + 1
	END IF

	RETURN

	ENTRY FLUSH_BULL(OCOUNT)_

	IF (POINT.LT.BRECLEN) OUTPUT(POINT+1:POINT+1) = CHAR(0)
	CALL WRITE_BULL_FILE(OCOUNT,OUTPUT(:BRECLEN))
	POINT = -1I

	RETURNm

	END


	SUBROUTINE WRITE_BULL_FILE(OCOUNT,OUTPUT)

	IMPLICIT INTEGER (A-Z)

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT

	CHARACTER*(*) OUTPUT(

	IF (REMOTE_SET) THENS
	   CALL REMOTE_WRITE_BULL_FILE(OUTPUT)$
	ELSE,
	   WRITE (1'OCOUNT) OUTPUTi
	END IF 

	RETURNT
	END


	SUBROUTINE GET_BULL_LINE(SBLOCK,BLENGTH,BUFFER,ILEN)R

	IMPLICIT INTEGER (A-Z)K

	INCLUDE 'BULLDIR.INC'

	CHARACTER*(*) BUFFER_

	COMMON /HEADER/ HEADER 
	LOGICAL HEADER /.TRUE./

	COMMON /DATE/ DATE_LINE
	CHARACTER*(INPUT_LENGTH) DATE_LINE 

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT

	COMMON /REF/ REFERENCES,LREFE
	CHARACTER*256 REFERENCES 

	IF (ILEN.GT.LINE_LENGTH) THEN		! First read?o
	   CALL STRIP_HEADER(BUFFER,0,IER)E
	   STRIP = .NOT.HEADERI
	   IBLOCK = SBLOCK			! Initialize pointers.
	   BULL_HEADER = .TRUE.
	   SEEN_FROM = .FALSE.I
	   SEEN_SUBJ = .FALSE.M
	   CALL GET_BULL(IBLOCK,BUFFER,ILEN))
	   IF (ILEN.LE.0) IBLOCK = IBLOCK + 1
	   MSG_SENT = .FALSE.
	   FINDREF = .NOT.STRIP.AND.REMOTE_SET.EQ.4
	ELSE					! Else set ILEN to zero 
	   ILEN = 0				! to request next line
	END IF)

	IF (MSG_SENT) THEN9
	   BUFFER = ' '
	   ILEN = 1
	   MSG_SENT = .FALSE.
	   RETURN
	END IFL

	DO WHILE (ILEN.GE.0)E
	   DO WHILE (ILEN.EQ.0)			! Read until line created
	      CALL GET_BULL(IBLOCK,BUFFER,ILEN)
	      IF (ILEN.LE.0) IBLOCK = IBLOCK + 1    ! Need to read new record.R
	      IF (IBLOCK.GE.SBLOCK+BLENGTH) RETURN  ! No more records.T
	   END DO

	   IF (STRIP.OR.FINDREF) THEN
	      IF (BULL_HEADER) THEN
		 IF (BUFFER(:5).EQ.'From:'.AND..NOT.SEEN_FROM) THENA
	            SEEN_FROM = .TRUE.N
		    RETURN
		 ELSE IF (BUFFER(:5).EQ.'Subj:'.AND..NOT.SEEN_SUBJ) THEN
	            SEEN_SUBJ = .TRUE.
		    RETURN
		 ELSE IF (BUFFER(:13).EQ.'Message sent:') THEN
		    MSG_SENT = .TRUE.M
		    RETURN
		 ELSER
		    BULL_HEADER = .FALSE.Y
		    IF (REMOTE_SET.EQ.4) FOUNDREF = .FALSE. 
		 END IFi
	      END IFI
              IF (REMOTE_SET.EQ.4.AND.ILEN.GT.12.AND.L
     &			(BUFFER(1:11).EQ.'References:'.OR.D
     &			 BUFFER(1:11).EQ.'Message-ID:')) THEN
	         IF (.NOT.FOUNDREF) LREF = 0 
	         FOUNDREF = .TRUE.t
		 IF (LREF.EQ.0) THEN
		    REFERENCES = BUFFER(13:ILEN)
		 ELSEA
		    REFERENCES = REFERENCES(:LREF)//' '//S
     &				BUFFER(13:ILEN) 
		 END IFS
		 LREF = TRIM(REFERENCES)
	      END IFe
	      IF (STRIP) THEN
	         IF (DATE_LINE.NE.' ') DATE_LINE = ' 'E
	         CALL STRIP_HEADER(BUFFER,ILEN,STRIP)
	         IF (DATE_LINE.NE.' ') THEN
		    BUFFER = DATE_LINE
		    ILEN = TRIM(DATE_LINE)
		    MSG_SENT = .TRUE.B
		    RETURN
	         END IF
	         IF (STRIP.OR.(.NOT.STRIP.AND.TRIM(BUFFER).EQ.0)) ILEN = 0=
	      ELSEF
	         IF (TRIM(BUFFER).EQ.0) THEN 
		    FINDREF = .FALSE.	
	            IF (.NOT.FOUNDREF) LREF = 0 R
	         END IF
	         RETURN
	      END IF 
	   ELSE
	      RETURN=
	   END IF
	END DOL

	RETURN2

	ENTRY TEST_MORE_RECORDS(SBLOCK,BLENGTH,IREC) 

	IREC = (SBLOCK+BLENGTH-1) - IBLOCKF

	RETURNT
	END


	SUBROUTINE GET_BULL(IBLOCK,BUFFER,OLEN)
C1
C  SUBROUTINE GET_BULL
CU
C  FUNCTION:  Outputs line from folder file.
C(
C  INPUT:R
C	IBLOCK	-	Input block number in input file to read from.I
CA
C  OUTPUT:
C	BUFFER  -	Character string containing output line.
C	OLEN	-	Length of character string.  If 0, signifies that
C			new record needs to be read, -1 signifies error.
C
C  NOTE:  Since message file is stored as a fixed length (128) record file,_
C	  but message lines are variable, message lines may span one orE
C	  more record.  This routine takes a record and outputs as many
C	  lines as it can from the record.  When no more lines can be
C	  outputted, it returns OLEN=0 requesting the calling program to
C	  increment the record counter.T
CI
	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLDIR.INC'

	COMMON /COMMAND_LINE/ INCMD
	CHARACTER*256 INCMD

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT

	COMMON /REMOTE_READ_MESSAGE/ SCRATCH_R1
	DATA SCRATCH_R1 /0/

	PARAMETER BRECLEN=128

	CHARACTER BUFFER*(*),TEMP*(BRECLEN), LEFT*(INPUT_LENGTH)(

	DATA POINT /1/, LEFT_LEN /0/ 

	IF (OLEN.GT.LINE_LENGTH) THEN		! First read?E
	   POINT = 1				! Initialize pointers.I
	   LEFT_LEN = 0
	   DTYPE = 0L
	END IFN

	IF (POINT.EQ.1) THEN			! Need to read new line?
10	   IF (INCMD(:4).EQ.'MOVE'.OR.INCMD(:4).EQ.'COPY') THEN
	      DO WHILE (REC_LOCK(IER))		! Read from fileT
	         READ (11'IBLOCK,IOSTAT=IER) TEMP
	      END DO	
	   ELSE IF (REMOTE_SET) THEN		! Remote folder?p
	      IF (IBLOCK.EQ.BLOCK) SCRATCH_R = SCRATCH_R1	! Read linesc
	      CALL READ_QUEUE(%VAL(SCRATCH_R),SCRATCH_R,TEMP)	! from queuer
	   ELSE					! Local folderw
	      DO WHILE (REC_LOCK(IER))		! Read from file 
	         READ (1'IBLOCK,IOSTAT=IER) TEMPl
	      END DOh
	   END IF
	   IF (OLEN.GT.LINE_LENGTH.AND.IER.EQ.0
     &		.AND.ICHAR(TEMP(:1)).EQ.0) THENl
	      DTYPE = 1
	      POINT = POINT + 1
           END IFO
	ELSE IF (POINT.EQ.BRECLEN+1) THEN	! Read all of lineI
	   OLEN = 0				! so indicate need to read
	   POINT = 1				! new line to calling routine.E
	   RETURN
	END IF 

	IF (IER.GT.0) THEN			! Error in reading file.
	   OLEN = -1				! OLEN = -1 signifies error
	   POINT = 1N
	   LEFT_LEN = 0
	   RETURN
	END IFe

	IF (LEFT_LEN.GT.0) THEN			! Part of line is left from
	   OLEN = ICHAR(LEFT(:1))		! previous record read.U
	   IF (LEFT_LEN.LE.BRECLEN) THEN	! Rest of it is in next record.E
 	      IF (DTYPE.EQ.0) THEN
	         BUFFER = LEFT(2:OLEN-LEFT_LEN+1)//
     &					TEMP(:LEFT_LEN) ! Output line.N
	      ELSE!
	         CALL UNCOMPRESS(LEFT(2:OLEN-LEFT_LEN+1) 
     &				 //TEMP(:LEFT_LEN),BUFFER,OLEN) 
 	      END IF
	      POINT = LEFT_LEN + 1		! Update pointers.
	      LEFT_LEN = 0'
	   ELSE					! Rest of line is longer than
	      LEFT(OLEN-LEFT_LEN+2:) = TEMP	! a record, so store record
	      LEFT_LEN = LEFT_LEN - BRECLEN	! and request another read.
	      OLEN = 0				! Request new record read. 
	   END IF
	ELSE					! Else nothing left over. 
	   OLEN = ICHAR(TEMP(POINT:POINT))	! Get line length 
	   IF (OLEN.GT.BRECLEN-POINT) THEN	! If it extends to next record
	      LEFT = TEMP(POINT:)		! Store it in leftover bufferI
	      LEFT_LEN = OLEN - (BRECLEN-POINT)	! Store leftover length
	      OLEN = 0				! Request new record read
	      POINT = 1				! Update record pointer.
	   ELSE IF (OLEN.EQ.0) THEN		! Empty line signifies
	      POINT = 1				! end of message.N
	   ELSE					! Else message line fully readO
	      ILEN = OLEN
	      IF (DTYPE.EQ.0) THEN 
	         BUFFER = TEMP(POINT+1:POINT+ILEN)	! So output it
	         OLEN = OLEN
	      ELSEL
	         CALL UNCOMPRESS(TEMP(POINT+1:POINT+ILEN),BUFFER,OLEN)
	      END IFB
	      POINT = POINT+ILEN+1		! and update pointer.
	   END IF
	END IFM

	RETURN

	ENTRY TEST_MORE_LINES(OLEN)	! Test for more lines in record.N
					! Returns length of next line.R
	IF (POINT.EQ.BRECLEN+1) THEN		! If pointer greater than
	   OLEN = 0				! record, no more lines.
	ELSE					! Else there is another line.Q
	   OLEN = ICHAR(TEMP(POINT:POINT))	! Output it's length.P
	END IF 

	RETURN 

	END





	SUBROUTINE DELETE_ENTRY(BULL_ENTRY)
C 
C  SUBROUTINE DELETE_ENTRY
C 
C  FUNCTION:
C	To delete a directory entry.
CA
C  INPUTS:
C	BULL_ENTRY  -  Bulletin entry number to delete
C

	IMPLICIT INTEGER (A-Z)(

	INCLUDE 'BULLDIR.INC'

	IF (NBULL.GT.0) THEN(
	   CALL READDIR(0,IER) 
	   NBULL = -NBULL
	   CALL WRITEDIR(0,IER)
	END IF 

	CALL DUMP_MESSAGE()

	CALL READDIR(BULL_ENTRY,IER)
	DELETE(UNIT=2)N

	NEMPTY = NEMPTY + LENGTHR

	CALL WRITEDIR(0,IER)U

	RETURN)
	END


	SUBROUTINE DUMP_MESSAGE()
CU
C  SUBROUTINE DUMP_MESSAGE
CP
C  FUNCTION:
C	To delete a directory entry.
CU
	IMPLICIT INTEGER (A-Z)N

	INCLUDE 'BULLFOLDER.INC' 

	INCLUDE 'BULLDIR.INC'

	INCLUDE 'BULLFILES.INC'

	INCLUDE '($ACLDEF)'

	INCLUDE '($SSDEF)'(

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT

	COMMON /ACL/ ACLENT
	CHARACTER ACLENT*256R

	CHARACTER DUMP_FILE*80 

	IF (BTEST(FOLDER_FLAG,1)) THENI
	   DUMP_FILE = FOLDER_FILEM
           IF (REMOTE_SET.EQ.4) THEN
	      DUMP_FILE = FOLDER_DESCRIP(:INDEX(FOLDER_DESCRIP,' ')-1)L
	      DO I=1,TRIM(DUMP_FILE)$
                 IF (DUMP_FILE(I:I).EQ.'.') DUMP_FILE(I:I) = '_'
	      END DO	
	      DUMP_FILE = NEWS_DIRECTORY(:TRIM(NEWS_DIRECTORY))//
     &				DUMP_FILEU
	   END IF
	   OPEN(UNIT=3,FILE=DUMP_FILE(:TRIM(DUMP_FILE))//'.LOG',
     &		IOSTAT=IER,STATUS='OLD',
     &		RECL=LINE_LENGTH,CARRIAGECONTROL='LIST',ACCESS='APPEND')
	   IF (IER.NE.0) THEN
	      OPEN(UNIT=3,FILE=DUMP_FILE(:TRIM(DUMP_FILE))//'.LOG',
     &		IOSTAT=IER,I
     &		RECL=LINE_LENGTH,STATUS='NEW',CARRIAGECONTROL='LIST')A
	      IF (IER.NE.0) RETURN 

	      IER = SYS$PARSE_ACL('(IDENTIFIER='//FOLDER_OWNER(
     &		:TRIM(FOLDER_OWNER))//',ACCESS=R+W+E+D+C)',ACLENT,,)
       	      IF (IER) THENT
		 CALL INIT_ITMLST	! Initialize item list
		 CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,E
     &			%LOC(ACLENT))
		 CALL END_ITMLST(ACL_ITMLST)	! Get address of itemlist

		 IER = SYS$CHANGE_ACL(,ACL$C_FILE,DUMP_FILE(:TRIM(
     &		   DUMP_FILE))//'.LOG',%VAL(ACL_ITMLST),,,)=
              END IF
	   ELSE
	      WRITE (3,'(A)') CHAR(12)W
	   END IF

	   CALL OPEN_BULLFILc

	   ILEN = LINE_LENGTH + 1

	   CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN)I
	   IF (ILEN.GT.0.AND.INPUT(:6).EQ.'From: ') THEN 
	      WRITE(3,1060) INPUT(7:ILEN),DATE//' '//TIME(:8)
	      CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN)
	   ELSE
	      WRITE(3,1060) FROM,DATE//' '//TIME(:8).
	   END IF
	   IF (ILEN.GT.0.AND.INPUT(:6).EQ.'Subj: ') THENE
	      WRITE(3,1050) INPUT(7:MIN(ILEN,LINE_LENGTH-3))U
	   ELSE
	      WRITE(3,1050) DESCRIP
	      IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN)
	   END IF

	   DO WHILE (ILEN.GT.0)
	      CALL GET_BULL_LINE(BLOCK,LENGTH,INPUT,ILEN)
	      IF (ILEN.GT.0) WRITE (3,'(A)') INPUT(:ILEN)
	   END DO

	   CLOSE (UNIT=3)			! Bulletin copy completed

	   CALL CLOSE_BULLFIL
	END IFF

1050	FORMAT('Subject: ',A,/)
1060	FORMAT(/,'From: ',A,' Date: ',A11) 

	RETURN 
	END



	SUBROUTINE GET_EXDATE(EXDATE,NDAYS)
C=
C  SUBROUTINE GET_EXDATE
CH
C  FUNCTION:  Computes expiration date giving number of days to expire.R
CE
	IMPLICIT INTEGER (A-Z)	

	CHARACTER*12 EXDATE

	CHARACTER*3 MONTHS(12)R
	DIMENSION LENGTH(12)
	DATA MONTHS/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', 
     &		    'OCT','NOV','DEC'/
	DATA LENGTH/31,27,31,30,31,30,31,31,30,31,30,31/ 

	CALL SYS$ASCTIM(,EXDATE,,)		! Get the present dateL

	DECODE(2,'(I2)',EXDATE(:2)) DAY	! Get day
	DECODE(4,'(I4)',EXDATE(8:11)) YEAR	! Get year

	MONTH = 1
	DO WHILE (MONTHS(MONTH).NE.EXDATE(4:6))	! Get month
	   MONTH = MONTH + 1 
	END DOI

	IF (MOD(YEAR,4).EQ.0) THEN		! Correct February length
	   LENGTH(2) = 28			! if we're in a leap year
	ELSE
	   LENGTH(2) = 27
	END IF 

	NUM_DAYS = NDAYS	! Put number of days into buffer variable,

	DO WHILE (NUM_DAYS.GT.0)L
	   IF (NUM_DAYS+DAY.GT.LENGTH(MONTH)) THEN
				! If expiration date exceeds end of month
	      NUM_DAYS = NUM_DAYS - (LENGTH(MONTH) - DAY + 1)
				! Decrement # of days by days left in montht
	      DAY = 1				! Reset day to first of month 
	      MONTH = MONTH + 1			! Increment month pointer
	      IF (MONTH.EQ.13) THEN		! Moved into next year?i
		 MONTH = 1			! Reset month pointer
		 YEAR = YEAR + 1		! Increment year pointer
	         IF (MOD(YEAR,4).EQ.0) THEN	! Correct February length
	            LENGTH(2) = 28		! if we're in a leap year
	         ELSE
	            LENGTH(2) = 27t
	         END IF
	      END IF
	   ELSE			! If expiration date is within the monthl
	      DAY = DAY + NUM_DAYS		! Find expiration day
	      NUM_DAYS = 0			! Force loop exitn
	   END IF
	END DOT

	ENCODE(2,'(I2)',EXDATE(:2)) DAY	! Put day into new date
	ENCODE(4,'(I4)',EXDATE(8:11)) YEAR	! Put year into new date
	EXDATE(4:6) = MONTHS(MONTH)		! Put month into new date_

	RETURNE
	END



	SUBROUTINE GET_LINE(INPUT,LEN_INPUT)E
CN
C  SUBROUTINE GET_LINE
C*
C  FUNCTION:
C	Gets line of input from terminal.N
C1
C  OUTPUTS:0
C	LEN_INPUT  -  Length of input line.  If = -1, CTRLC entered.
C		      if = -2, CTRLZ entered.
CE
C  NOTES:
C	Also, on first call, set LEN_INPUT to 1+LENGTH OF INPUT CHARCTER
C	for initializing the CTRLC AST.O
C.

	IMPLICIT INTEGER (A-Z)N

	LOGICAL*1 DESCRIP(8),DTYPE,CLASSR
	INTEGER*2 LENGTH 
	CHARACTER*(*) INPUT
	EQUIVALENCE (DESCRIP(1),LENGTH),(DESCRIP(3),DTYPE)_
	EQUIVALENCE (DESCRIP(4),CLASS),(DESCRIP(5),POINTER)

        DATA LENGTH/0/,DTYPE/0/,CLASS/2/,POINTER/0/E

	EXTERNAL SMG$_EOF

	COMMON /DECNET/ DECNET_PROC,ERROR_UNIT	
	LOGICAL DECNET_PROC

	COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID

	COMMON /CTRLC_FLAG/ FLAGO

	CHARACTER PROMPT*(*),NULLPROMPT*4
	LOGICAL USE_PROMPTL

	USE_PROMPT = .FALSE..

	GO TO 5

	ENTRY GET_INPUT_PROMPT(INPUT,LEN_INPUT,PROMPT)1

	USE_PROMPT = .TRUE.

5	LIMIT = LEN(INPUT)			! Get input line size limit
	INPUT = ' '				! Clean out input buffer

Ci
C  Initialize CTRL-C AST with AST routine CTRLC_ROUTINE andr
C  AST parameter FLAG.  When CTRLC occurs, FLAG is set to 1o
Cn

	CALL DECLARE_CTRLC_AST-

	LEN_INPUT = 0				! Nothing inputted yet

C
C  LIB$GET_INPUT is nice way of getting input from terminal,
C  as it handles such thing as accidental wrap around to next line.v
Cs

	IF (DECNET_PROC) THEN
	   READ (5,'(Q,A)',IOSTAT=IER) LEN_INPUT,INPUTe
	   IF (IER.NE.0) LEN_INPUT = -2 N
	   RETURN
	ELSE IF (USE_PROMPT) THEN
	   IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID,
     &		DESCRIP,PROMPT)		! Get line from terminal with prompt&
	ELSET
	   IER = SMG$READ_COMPOSED_LINE(KEYBOARD_ID,KEY_TABLE_ID,
     &		DESCRIP,NULLPROMPT(:1))	! Get line from terminal with no promptR
	END IFn

	IF (.NOT.IER.AND.IER.NE.%LOC(SMG$_EOF)) CALL EXIT(IER)r

	CALL STR$TRIM(DESCRIP,DESCRIP,LEN_INPUT)T

	IF (FLAG.EQ.0) THEN			! If no CTRL-C has occurred
	   CALL CANCEL_CTRLC_AST		! Cancel CTRL-C AST
	   IF (IER.NE.%LOC(SMG$_EOF)) THEN	! End of input?H
	      LEN_INPUT = MIN(LIMIT,LENGTH)	! No. Get length of lineE
	      DO I=0,LEN_INPUT-1		! Extract from descriptor
	         CALL GET_VAL(INPUT(I+1:I+1),%VAL(POINTER+I))
	      END DOL
	      CALL CONVERT_TABS(INPUT,LEN_INPUT)h
	      LEN_INPUT = MAX(LEN_INPUT,LENGTH)
	   ELSE
	      LEN_INPUT = -2			! If CTRL-Z, say so 
	   END IF
	ELSE 
	   LEN_INPUT = -1			! If CTRL-C, say so
	END IF 
	RETURNs
	END



	SUBROUTINE CONVERT_TABS(INPUT,LEN_INPUT) 

	IMPLICIT INTEGER (A-Z) 

	CHARACTER*(*) INPUT

	PARAMETER TAB = CHAR(9)

	LIMIT = LEN(INPUT) 

	DO WHILE (INDEX(INPUT,TAB).GT.0.AND.LEN_INPUT.LT.LIMIT)
	   TAB_POINT = INDEX(INPUT,TAB)	! Remove tabs
	   MOVE = ((TAB_POINT-1)/8)*8 + 9
	   ADD = MOVE - TAB_POINT
	   IF (MOVE-1.LE.LIMIT) THENT
	      INPUT(MOVE:) = INPUT(TAB_POINT+1:) 
	      DO I = TAB_POINT,MOVE-1
	         INPUT(I:I) = ' '
	      END DOT
	      LEN_INPUT = LEN_INPUT + ADD - 1
	   ELSE
	      DO I = TAB_POINT,LIMIT 
	         INPUT(I:I) = ' '
	      END DOi
	      LEN_INPUT = LIMIT+1
	   END IF
	END DOt

        CALL FILTER (INPUT, LEN_INPUT)

	RETURN
	END


	SUBROUTINE FILTER (INCHAR, LENGTH)S

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) INCHAR 

	DO I = 1,LENGTH
	   IF ((INCHAR(I:I).LT.' '.AND.
     &      INCHAR(I:I).NE.CHAR(13).AND.INCHAR(I:I).NE.CHAR(10)))I
     &	    INCHAR(I:I) = '.'
	END DO)

	RETURN 
	END


	SUBROUTINE GET_VAL(OUTPUT,INPUT)	! Used to convert logicalD
	CHARACTER*(*) OUTPUT			! byte to character valueE
	LOGICAL*1 INPUT
	OUTPUT = CHAR(INPUT) 
	RETURNL
	END

	SUBROUTINE CTRLC_ROUTINE		! CTRL-C AST routineS
	IMPLICIT INTEGER (A-Z)			! If CTRL-C, come here

	COMMON /CTRLY/ CTRLY

	COMMON /CTRLC_FLAG/ FLAG.

	COMMON /DEF_PROT/ ORIGINAL_DEF_PROT

	IF (FLAG.EQ.2) THEN
	   CALL LIB$PUT_OUTPUT('Bulletin aborting...')'
	   CALL SYS$CANEXH()'
	   CALL SYS$SETDFPROT(ORIGINAL_DEF_PROT,)
	   CALL LIB$ENABLE_CTRL(CTRLY,)		! Enable CTRL-Y & -C
	   CALL EXITN
	END IF
	FLAG = 1				! to set flag
	RETURNT
	END



	SUBROUTINE DECLARE_CTRLC_ASTD
CF
C  SUBROUTINE DECLARE_CTRLC_ASTQ
C 
C  FUNCTION:
C	Declares a CTRLC ast.(
C  NOTES:E
C	Assumes terminal assigned to TERM_CHAN in common /TERM_CHAN/. 
CI
	IMPLICIT INTEGER (A-Z) 

	EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,CTRLC_ROUTINEE
	COMMON /TERM_CHAN/ TERM_CHANR

	COMMON /CTRLC_FLAG/ FLAGL

	FLAG = 0				! Init CTRL-C flagE
	IO_CTRLC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST)	! Set AST code
	IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,,	! for QIOS
     &	      CTRLC_ROUTINE,,,,,)		! Enable the AST

	RETURNP

	ENTRY CANCEL_CTRLC_ASTL

	IER = SYS$CANCEL(%VAL(TERM_CHAN))

	FLAG = 2		! Indicates that a CTRLC will cause an exit
	IER=SYS$QIOW(,%VAL(TERM_CHAN),%VAL(IO_CTRLC),,,,	! for QIOT
     &	      CTRLC_ROUTINE,,,,,)		! Enable the AST

	RETURNR
	END




	SUBROUTINE GET_INPUT_NOECHO(DATA)
C	
C  SUBROUTINE GET_INPUT_NOECHO
C 
C  FUNCTION: Reads data in from terminal without echoing characters.
C	     Also contains entry to assign terminal.
CG
	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) DATA,PROMPT

	COMMON /TERM_CHAN/ TERM_CHAN 

	COMMON /SMG/ KEYBOARD_ID,KEY_TABLE_ID

	COMMON /CTRLC_FLAG/ FLAGL

	COMMON /READIT/ READITC

	INCLUDE '($TRMDEF)'

	INTEGER TERMSET(2)

	INTEGER MASK(4)
	DATA MASK/4*'FFFFFFFF'X/L

	DATA PURGE/.TRUE./U

	DO I=1,LEN(DATA)N
	   DATA(I:I) = ' 'Q
	END DO)

	IF (PURGE) THEN
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA), 
     &		TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE)
	   PURGE = .FALSE.1
	ELSEO
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),N
     &		TRM$M_TM_NOECHO)
	END IF 

	RETURN1

	ENTRY GET_INPUT_NOECHO_PROMPT(DATA,PROMPT)E

	DO I=1,LEN(DATA))
	   DATA(I:I) = ' 'I
	END DO 

	IF (PURGE) THEN
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA), 
     &		TRM$M_TM_NOECHO.OR.TRM$M_TM_PURGE)
	   PURGE = .FALSE.T
	ELSEA
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,PROMPT,LEN(DATA),i
     &		TRM$M_TM_NOECHO)
	END IFB

	RETURND

	ENTRY GET_INPUT_NUM(DATA,NLEN))

	DO I=1,LEN(DATA):
	   DATA(I:I) = ' '
	END DO 

	IF (PURGE) THEN
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),X
     &		TRM$M_TM_PURGE,,TERMSET,NLEN,TERM)
	   PURGE = .FALSE. 
	ELSE 
	   CALL SMG$READ_STRING(KEYBOARD_ID,DATA,,LEN(DATA),,,X
     &		TERMSET,NLEN,TERM)
	END IFM

	IF (TERM.NE.13.AND.TERM.NE.510.AND.NLEN.EQ.0) THEN'
				! Input did not end with CR or buffer full
	   NLEN = 1
	   DATA(:1) = CHAR(TERM)0
	END IF,

	RETURN,

	ENTRY ASSIGN_TERMINAL

	IER = SYS$ASSIGN('TT',TERM_CHAN,,)	! Assign terminalD

	CALL DECLARE_CTRLC_ASTC

	FLAG = 2		! Indicates that a CTRLC will cause an exit

	IER = SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID,,,,20) 

	IER = SMG$CREATE_KEY_TABLE(KEY_TABLE_ID),

	IER = SMG$SET_KEYPAD_MODE(KEYBOARD_ID,0) 

	IF (CLI$PRESENT('KEYPAD')) THEN
	   CALL SET_KEYPADE
	ELSE IF (READIT.EQ.0) THENM
	   CALL SET_NOKEYPADb
	END IFs

	TERMSET(1) = 16
	TERMSET(2) = %LOC(MASK)

	DO I=ICHAR('0'),ICHAR('9').
	   MASK(2) = IBCLR(MASK(2),I-32)r
	END DOe

	RETURNd
	END





	SUBROUTINE GETPAGSIZ(PAGE_LENGTH,PAGE_WIDTH) 
C
C  SUBROUTINE GETPAGSIZ 
Cd
C  FUNCTION:
C	Gets page size of the terminal. 
Cf
C  OUTPUTS: 
C	PAGE_LENGTH  -  Page length of the terminal.
C	PAGE_WIDTH   -  Page size of the terminal.
Co
	IMPLICIT INTEGER (A-Z)1

	INCLUDE '($DVIDEF)'

	LOGICAL*1 DEVDEPEND(4)r

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(4,DVI$_DEVDEPEND,%LOC(DEVDEPEND(1)))T
	CALL ADD_2_ITMLST(4,DVI$_DEVBUFSIZ,%LOC(PAGE_WIDTH)) 
	CALL END_ITMLST(GETDVI_ITMLST)		! Get address of itemlist

	CALL SYS$GETDVIW(,,'TT',%VAL(GETDVI_ITMLST),,,,)l

	PAGE_LENGTH = ZEXT(DEVDEPEND(4)) 

	PAGE_WIDTH = MIN(PAGE_WIDTH,132)	

	RETURNp
	END





	LOGICAL FUNCTION SLOW_TERMINALE
CT
C  FUNCTION SLOW_TERMINALe
Ca
C  FUNCTION:
C	Indicates that terminal has a slow speed (2400 baud or less).=
CN
C  OUTPUTS: 
C	SLOW_TERMINAL = .true. if slow, .false. if not.S
CO

	IMPLICIT INTEGER (A-Z)P

	EXTERNAL IO$_SENSEMODE_

	COMMON /TERM_CHAN/ TERM_CHANn

	COMMON CHAR_BUF(2)l

	LOGICAL*1 IOSB(8)

	INCLUDE '($TTDEF)'o

	IER = SYS$QIOW(,%VAL(TERM_CHAN),IO$_SENSEMODE,IOSB,,,
     &		  CHAR_BUF,%VAL(8),,,,)	

	IF (IOSB(3).LE.TT$C_BAUD_2400.AND.IOSB(3).NE.0) THENH
	   SLOW_TERMINAL = .TRUE.
	ELSEC
	   SLOW_TERMINAL = .FALSE.E
	END IF

	RETURN1
	END




	SUBROUTINE SHOW_PRIVL
CT
C  SUBROUTINE SHOW_PRIV
CU
C  FUNCTION:
C	To show privileges necessary for managing bulletin board.C
CS

	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLUSER.INC'0

	INCLUDE 'BULLFILES.INC'

	INCLUDE '($PRVDEF)'

	INCLUDE '($SSDEF)'C

	COMMON /PRVDEF/ PRIVS
	CHARACTER*8 PRIVS(0:38)

	CALL OPEN_BULLUSER_SHARED		! Get BULLUSER.DAT file

	CALL READ_USER_FILE_HEADER(IER)

	IF (IER.EQ.0) THEN			! If header is present, exit
	   IF (NEW_FLAG(1).EQ.-1.AND.NEW_FLAG(2).EQ.-1) THEN  ! Info not present 
	      CALL CLOSE_BULLUSER
	      CALL OPEN_BULLUSER			! Get BULLUSER.DAT filel
	      CALL READ_USER_FILE_HEADER(IER)
	      USERPRIV(1) = PRV$M_OPER.OR.PRV$M_CMKRNL.OR.PRV$M_SETPRVr
	      USERPRIV(2) = 0
	      REWRITE (4) USER_HEADER
	   END IF
	   WRITE (6,'('' Following privileges are needed for privileged
     & commands:'')')o
	   DO I=0,38 
	      IF ((I.LT.32.AND.BTEST(USERPRIV(1),I)).OR.d
     &		  (I.GT.31.AND.BTEST(USERPRIV(2),I-32))) THENC
		 WRITE (6,'(1X,A)') PRIVS(I)
	      END IFU
	   END DO
	ELSEE
	   WRITE (6,'('' ERROR: Cannot show privileges.'')')M
	END IF

	CALL CLOSE_BULLUSER			! All finished with BULLUSERI

	CALL CHKACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE)),IER)h
	IF (IER.NE.(SS$_ACLEMPTY.OR.SS$_NORMAL).AND.IER) THEN
	   CALL SHOWACL(BULLUSER_FILE(:TRIM(BULLUSER_FILE))) 
	END IFf

	RETURNl

	END




	SUBROUTINE SET_PRIV
CE
C  SUBROUTINE SET_PRIV
C)
C  FUNCTION:
C	To set privileges necessary for managing bulletin board.
CQ

	IMPLICIT INTEGER (A-Z)a

	INCLUDE '($PRVDEF)'

	INCLUDE 'BULLUSER.INC'L

	COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2)

	COMMON /PRVDEF/ PRIVS
	CHARACTER*8 PRIVS(0:38)
	DATA PRIVSt
     &	/'CMKRNL','CMEXEC','SYSNAM','GRPNAM','ALLSPOOL','DETACH',
     &  'DIAGNOSE','LOG_IO','GROUP','ACNT','PRMCEB','PRMMBX','PSWAPM',
     &	'ALTPRI','SETPRV','TMPMBX','WORLD','MOUNT','OPER','EXQUOTA',N
     &	'NETMBX','VOLPRO','PHY_IO','BUGCHK','PRMGBL','SYSGBL','PFNMAP',
     &	'SHMEM','SYSPRV','BYPASS','SYSLCK','SHARE','UPGRADE','DOWNGRADE',
     &	'GRPPRV','READALL',' ',' ','SECURITY'/P

	EXTERNAL CLI$_ABSENT,CLI$_NEGATED

	DIMENSION ONPRIV(2),OFFPRIV(2)R

	CHARACTER*32 INPUT_PRIV

	IF (.NOT.SETPRV_PRIV().OR..NOT.BTEST(PROCPRIV(1),PRV$V_SETPRV)) THENI
	   WRITE (6,'('' ERROR: This command requires SETPRV privileges.'')')
	   RETURN
	END IFD

	IF (CLI$PRESENT('ID').OR.
     &		CLI$PRESENT('ID').EQ.%LOC(CLI$_NEGATED)) THEN_
	   DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN)(
     &	       .NE.%LOC(CLI$_ABSENT))		! Get the IDsP
	      IF (CLI$PRESENT('ID')) THEN
		 CALL ADD_ACL(INPUT_PRIV(:PLEN),'R+C',IER)
	      ELSED
		 CALL DEL_ACL(INPUT_PRIV(:PLEN),'R+C',IER)
	      END IF 
	      IF (.NOT.IER) CALL SYS_GETMSG(IER)
	   END DO
	   RETURN
	END IFN

	OFFPRIV(1) = 0I
	OFFPRIV(2) = 0A
	ONPRIV(1) = 0
	ONPRIV(2) = 0

	DO WHILE (CLI$GET_VALUE('PRIVILEGES',INPUT_PRIV,PLEN)
     &	    .NE.%LOC(CLI$_ABSENT))		! Get the privileges0
	   PRIV_FOUND = -1A
	   I = 0'
	   DO WHILE (I.LT.39.AND.PRIV_FOUND.EQ.-1) 
	      IF (INPUT_PRIV(:PLEN).EQ.PRIVS(I)) PRIV_FOUND = I
	      IF (INPUT_PRIV(3:PLEN).EQ.PRIVS(I)) PRIV_FOUND = IT
	      I = I + 1
	   END DO
	   IF (PRIV_FOUND.EQ.-1) THEN
	      WRITE(6,'('' ERROR: Incorrectly specified privilege = '',
     &		A)') INPUT_PRIV(:PLEN)
	      RETURNM
	   ELSE IF (INPUT_PRIV(:2).EQ.'NO') THEN/
	      IF (INPUT_PRIV.EQ.'NOSETPRV') THEN
	       WRITE(6,'('' ERROR: Cannot remove SETPRV privileges.'')')X
	       RETURN
	      ELSE IF (PRIV_FOUND.LT.32) THEN
		 OFFPRIV(1) = IBSET(OFFPRIV(1),PRIV_FOUND)
	      ELSEE
		 OFFPRIV(2) = IBSET(OFFPRIV(2),PRIV_FOUND-32)R
	      END IF
	   ELSE
	      IF (PRIV_FOUND.LT.32) THENT
		 ONPRIV(1) = IBSET(ONPRIV(1),PRIV_FOUND)
	      ELSER
		 ONPRIV(2) = IBSET(ONPRIV(2),PRIV_FOUND-32)e
	      END IFi
	   END IF
	END DO 

	CALL OPEN_BULLUSER		! Get BULLUSER.DAT file

	CALL READ_USER_FILE_HEADER(IER)

	IF (IER.EQ.0) THEN			! If header is present, exit
	   USERPRIV(1) = USERPRIV(1).OR.ONPRIV(1)
	   USERPRIV(2) = USERPRIV(2).OR.ONPRIV(2)
	   USERPRIV(1) = USERPRIV(1).AND.(.NOT.OFFPRIV(1)))
	   USERPRIV(2) = USERPRIV(2).AND.(.NOT.OFFPRIV(2))U
	   REWRITE (4) USER_HEADER
	   WRITE (6,'('' Privileges successfully modified.'')')
	ELSET
	   WRITE (6,'('' ERROR: Cannot modify privileges.'')')u
	END IFt

	CALL CLOSE_BULLUSER			! All finished with BULLUSERo

	RETURN 

	END



	SUBROUTINE ADD_ACL(ID,ACCESS,IER)
CT
C  SUBROUTINE ADD_ACLB
CT
C  FUNCTION: Adds ACL to bulletin files.
C 
C  PARAMETERS:
C	ID - Character string containing identifier to add to ACL.
C	ACCESS - Character string containing access controls to give to ID.I
C	IER - Return error from attempting to set ACL.
CC
C  NOTE: The ID must be in the RIGHTS data base.
CD
	IMPLICIT INTEGER (A-Z)O

	INCLUDE 'BULLFOLDER.INC'O

	INCLUDE 'BULLFILES.INC'

	COMMON /ACL/ ACLENT
	CHARACTER ACLENT*256G

	CHARACTER ID*(*),ACCESS*(*),NEWS_ACCESS*132

	INCLUDE '($ACLDEF)'

	INCLUDE '($SSDEF)'I

	IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS='R
     &	   //ACCESS//')',ACLENT,,)T
	IF (.NOT.IER) THENM
	   IF (IER.EQ.SS$_NOSUCHID.AND.ADDID.AND.
     &				INDEX(ACCESS,'C').EQ.0) THEN
	      CALL GET_UAF(ID,USER,GROUP,ACCOUNT,FLAGS,IER)
	      IF (.NOT.IER) THENE
		 CALL ERRSNS(IDUMMY,IER)
		 WRITE (6,'(
     &		    '' ERROR: Specified username cannot be verified.'')') 
		 CALL SYS_GETMSG(IER)T
	         RETURN
	      END IFD
	      IDENT = USER + ISHFT(GROUP,16)M
	      IER = SYS$ADD_IDENT(ID,%VAL(IDENT),,)
	      IF (IER) THEN
	         IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS='
     &	           //ACCESS//')',ACLENT,,)M
	      END IF
	   END IF
	END IF 
	IF (.NOT.IER) RETURND

	CALL INIT_ITMLST	! Initialize item list
	CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_ADDACLENT,%LOC(ACLENT))
	CALL END_ITMLST(ACL_ITMLST)	! Get address of itemlist

	IF (INDEX(ACCESS,'C').GT.0.AND.INDEX(ACCESS,'W').EQ.0) THEN
	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM(L
     &		   BULLUSER_FILE)),%VAL(ACL_ITMLST),,,)r
	   RETURN
	END IFN

	IF (INDEX(FOLDER1,'.').GT.0) THEN
  	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,NEWS_ACCESS(FOLDER1_DESCRIP)T
     &	      ,%VAL(ACL_ITMLST),,,)
        ELSE
  	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILEc
     &	      (:TRIM(FOLDER1_FILE))//'.BULLFIL',%VAL(ACL_ITMLST),,,) 
	END IF=

	RETURN_
	END



	SUBROUTINE DEL_ACL(ID,ACCESS,IER)
CO
C  SUBROUTINE DEL_ACLI
CC
C  FUNCTION: Adds ACL to bulletin files.
CA
C  PARAMETERS:
C	ID - Character string containing identifier to add to ACL.
C	ACCESS - Character string containing access controls to give to ID. 
C	IER - Return error from attempting to set ACL.
C
C  NOTE: The ID must be in the RIGHTS data base.
CE
	IMPLICIT INTEGER (A-Z)N

	INCLUDE 'BULLFOLDER.INC':

	INCLUDE 'BULLFILES.INC'

	COMMON /ACL/ ACLENT
	CHARACTER ACLENT*256a

	CHARACTER ID*(*),ACCESS*(*),NEWS_ACCESS*132

	INCLUDE '($ACLDEF)'

	IF (ID.NE.' ') THEN
	   IER = SYS$PARSE_ACL('(IDENTIFIER='//ID//',ACCESS='
     &	      //ACCESS//')',ACLENT,,)
	   IF (.NOT.IER) RETURN

	   CALL INIT_ITMLST	! Initialize item list 
	   CALL ADD_2_ITMLST(ICHAR(ACLENT(:1)),ACL$C_DELACLENT,%LOC(ACLENT))V
	   CALL END_ITMLST(ACL_ITMLST)	! Get address of itemlist,
	ELSEA
	   CALL INIT_ITMLST	! Initialize item list(
	   CALL ADD_2_ITMLST(255,ACL$C_DELETEACL,%LOC(ACLENT))R
	   CALL END_ITMLST(ACL_ITMLST)	! Get address of itemlistT
	END IFT

	IF (INDEX(ACCESS,'C').GT.0) THEN
	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,BULLUSER_FILE(:TRIM(s
     &		   BULLUSER_FILE)),%VAL(ACL_ITMLST),,,)i
	   RETURN
	END IFt

	IF (INDEX(FOLDER1,'.').GT.0) THEN
  	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,NEWS_ACCESS(FOLDER1_DESCRIP) 
     &	      ,%VAL(ACL_ITMLST),,,)
        ELSE
  	   IER = SYS$CHANGE_ACL(,ACL$C_FILE,FOLDER1_FILEE
     &	      (:TRIM(FOLDER1_FILE))//'.BULLFIL',%VAL(ACL_ITMLST),,,)C
	END IF0

	RETURN)
	END




	SUBROUTINE CREATE_FOLDER
CS
C  SUBROUTINE CREATE_FOLDERE
C
C  FUNCTION: Creates a new bulletin folder.N
CH

	IMPLICIT INTEGER (A-Z) 

	INCLUDE 'BULLFOLDER.INC'

	INCLUDE 'BULLUSER.INC'a

	INCLUDE 'BULLFILES.INC'

	INCLUDE 'BULLDIR.INC'

	COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT
	DATA REMOTE_SET /.FALSE./

	COMMON /BULL_CUSTOM/ BULL_CUSTOM

	IF (CLI$PRESENT('NEWS')) THEN
	   CALL CREATE_NEWS_FOLDERN
	   RETURN
	END IFe

	IF (.NOT.SETPRV_PRIV().AND.(CLI$PRESENT('NEEDPRIV').OR.
     &		BTEST(BULL_CUSTOM,0))) THENp
	   WRITE(6,'('' ERROR: CREATE is a privileged command.'')')
	   RETURN
	END IFs

	IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER,LEN_T) ! Get folder name

	IF (LEN_T.GT.44) THEN
	   WRITE(6,'('' ERROR: Folder name must be < 45 characters.'')')V
	   RETURN
	END IFT

	IF (.NOT.SETPRV_PRIV().AND.(CLI$PRESENT('ALWAYS').OR.
     &	     CLI$PRESENT('NOTIFY').OR.CLI$PRESENT('READNEW').OR. 
     &	     CLI$PRESENT('BRIEF').OR.CLI$PRESENT('SYSTEM'))) THEN
	   WRITE (6,'('' ERROR: Privileged qualifier specified.'')')D
	   RETURN
	END IF3

	IF (CLI$PRESENT('NODE')) THEN	! Remote node specified?
	   IER = CLI$GET_VALUE('NODE',FOLDER_BBOARD,LEN_B) ! Get node name'
	   FOLDER_BBOARD = '::'//FOLDER_BBOARD(:LEN_B)n
	   FOLDER1_BBOARD = FOLDER_BBOARD
	   IF (.NOT.CLI$GET_VALUE('REMOTENAME',FOLDER1,LEN_P)) THEN
	      FOLDER1 = FOLDERD
	   ELSE IF (LEN_P.GT.40) THEN
	      WRITE (6,'('' ERROR: REMOTENAME cannot be longer '',E
     &			 ''than 40 characters.'')')
	   END IF
	   FOLDER1_NUMBER = FOLDER_MAXo
	   CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) 
	   IF (IER.NE.0) THEN
	    WRITE (6,'('' ERROR: Folder not accessible on remote node.'')')
	    RETURNI
	   ELSE IF (CLI$PRESENT('SYSTEM').AND. 
     &				.NOT.BTEST(FOLDER1_FLAG,2)) THEN
	    WRITE (6,'('' ERROR: /SYSTEM not allowed as remote node'','
     &			'' is not SYSTEM folder.'')')
	    RETURN'
	   END IF
	END IFS

	LENDES = 0'
	DO WHILE (LENDES.EQ.0),
	   IF (CLI$PRESENT('DESCRIPTION')) THEN		! DESCRIPTION specified?
	      IER = CLI$GET_VALUE('DESCRIPTION',FOLDER_DESCRIP,LENDES)B
	   ELSE
	      WRITE (6,'('' Enter one line description of folder.'')') 
	      CALL GET_LINE(FOLDER_DESCRIP,LENDES)	! Get input line
	      FOLDER_DESCRIP = FOLDER_DESCRIP(:LENDES)	! End fill with spaces
	   END IF
	   IF (LENDES.LE.0) THEN,
	      WRITE (6,'('' Aborting folder creation.'')')o
	      RETURNS
	   ELSE IF (LENDES.GT.80) THEN		! If too many charactersE
	      WRITE(6,'('' ERROR: folder must be < 80 characters.'')')T
	      LENDES = 0(
	   END IF
	END DOE

	CALL OPEN_BULLFOLDER		! Open folder fileC
	READ (7,IOSTAT=IER,KEY=FOLDER,KEYID=0) 
					! See if folder existsC

	IF (IER.EQ.0) THEN:
	   WRITE (6,'('' ERROR: Specified folder already exists.'')')
	   GO TO 1000
	END IFI

	IF (CLI$PRESENT('OWNER')) THENE
	   IF (.NOT.SETPRV_PRIV().AND..NOT.CLI$PRESENT('ID')) THEN 
	      WRITE (6,'('' ERROR: /OWNER requires privileges.'')')
	      CALL CLOSE_BULLFOLDER
	      RETURNE
	   ELSE
	      CALL CLI$GET_VALUE('OWNER',FOLDER1_OWNER,LEN_P)
	      IF (LEN_P.GT.12) THEN
	         WRITE (6,'('' ERROR: Folder owner name must be'',T
     &		        '' no more than 12 characters long.'')')
	         CALL CLOSE_BULLFOLDERO
	         RETURN
	      ELSE IF (CLI$PRESENT('ID')) THENE
		 IER = CHKPRO(FOLDER1_OWNER)
	         IF (.NOT.IER) THEN
	            WRITE (6,'('' ERROR: ID not valid.'')')
	            CALL CLOSE_BULLFOLDER
	            RETURN 
		 END IFT
	      ELSEE
	         CALL GET_UAF
     &		   (FOLDER1_OWNER,USERB1,GROUPB1,ACCOUNTB1,FLAGS,IER) 
	         IF (.NOT.IER) THEN
	            WRITE (6,'('' ERROR: Owner not valid username.'')')
	            CALL CLOSE_BULLFOLDER
	            RETURN-
		 END IF 
	      END IFL
	      FOLDER_OWNER = FOLDER1_OWNERT
	   END IF
	ELSES
	   FOLDER_OWNER = USERNAME		! Get present username=
	   FOLDER1_OWNER = FOLDER_OWNER		! Save for later
	END IF

	FOLDER_SET = .TRUE.

	CALL SYS$SETDFPROT('FF00'X,CUR_DEF_PROT)D
			! Set protection to (SYSTEM:RWED,OWNER:RWED,WORLD,GROUP)s

Ce
C  Folder file is placed in the directory FOLDER_DIRECTORY.R
C  The file prefix is the name of the folder.V
C 

	FD_LEN = TRIM(FOLDER_DIRECTORY)
	IF (FD_LEN.EQ.0) THEN
	 WRITE (6,'('' ERROR: System programmer has disabled folders.'')')T
	 GO TO 910v
	ELSEs
	 FOLDER_FILE = FOLDER_DIRECTORY(:FD_LEN)//FOLDER'
	END IFC

	OPEN (UNIT=2,FILE=FOLDER_FILE(1: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') 

	IF (IER.NE.0) THENt
	   WRITE(6,'('' ERROR: Cannot create folder directory file.'')')n
	   CALL ERRSNS(IDUMMY,IER) 
	   CALL SYS_GETMSG(IER)
	   GO TO 910R
	END IFa

	OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))
     1	 //'.BULLFIL',STATUS='NEW',
     1	 ACCESS='DIRECT',RECORDTYPE='FIXED',RECORDSIZE=32,A
     1	 FORM='UNFORMATTED',IOSTAT=IER)

	IF (IER.NE.0) THEN'
	   WRITE(6,'('' ERROR: Cannot create folder message file.'')')I
	   CALL ERRSNS(IDUMMY,IER)C
	   CALL SYS_GETMSG(IER)
	   GO TO 910M
	END IF(

	FOLDER_FLAG = 0

	IF (CLI$PRESENT('PRIVATE').OR.CLI$PRESENT('SEMIPRIVATE')) THEN 
				! Will folder have access limitations?
	   FOLDER1_FILE = FOLDER_FILE
	   CLOSE (UNIT=1)
	   CLOSE (UNIT=2)
	   FOLDER1 = FOLDER	! Save for ADD_ACLn
	   IF (CLI$PRESENT('SEMIPRIVATE')) THEN
	      CALL ADD_ACL('*','R',IER)
	   ELSE
	      CALL ADD_ACL('*','NONE',IER)
	   END IF
	   CALL ADD_ACL(FOLDER_OWNER,'R+W+C',IER)
	   OPEN (UNIT=2,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))'
     1	    //'.BULLDIR',STATUS='OLD',IOSTAT=IER1)C
	   OPEN (UNIT=1,FILE=FOLDER_FILE(:TRIM(FOLDER_FILE))O
     1	    //'.BULLFIL',STATUS='OLD',IOSTAT=IER1)e
	   IF (.NOT.IER) THEN
	      WRITE(6,1
     &	      '('' ERROR: Cannot create private folder using ACLs.'')')
	      CALL SYS_GETMSG(IER)X
	      GO TO 910
	   END IF
	   FOLDER_FLAG = IBSET(FOLDER_FLAG,0)
	END IFC

	IER = 0
	LAST_NUMBER = 1
	DO WHILE (IER.EQ.0.AND.LAST_NUMBER.LT.FOLDER_MAX-1)
	   READ (7,IOSTAT=IER,KEY=LAST_NUMBER,KEYID=1)0
	   LAST_NUMBER = LAST_NUMBER + 1,
	END DOE

	IF (IER.EQ.0) THENS
	 WRITE (6,'('' ERROR: Folder limit of '',I,'' has been reached.'')')Y
     &			FOLDER_MAXI
	 WRITE (6,'('' Unable to add specified folder.'')')
	 GO TO 910A
	ELSET
	   FOLDER1_NUMBER = LAST_NUMBER - 1
	END IFS

	IF (.NOT.CLI$PRESENT('NODE')) THEN 
	   FOLDER_BBOARD = 'NONE'
	   IF (REMOTE_SET) CLOSE (UNIT=REMOTE_UNIT)
	   REMOTE_SET = .FALSE.
	   FOLDER_BBEXPIRE = 14
	   F_NBULL = 0 
	   NBULL = 0-
	   F_NEWEST_BTIM(1) = 0
	   F_NEWEST_BTIM(2) = 0
	   F_NEWEST_NOSYS_BTIM(1) = 0
	   F_NEWEST_NOSYS_BTIM(2) = 0
	   F_EXPIRE_LIMIT = 0
	   FOLDER_NUMBER = FOLDER1_NUMBER
	ELSEE
	   CLOSE (UNIT=1,STATUS='DELETE')
	   CLOSE (UNIT=2,STATUS='DELETE')
	   IF (FOLDER1.NE.FOLDER) THEN	! Different remote folder name?,
	      REMOTE_SET = .FALSE.
    	      CALL OPEN_BULLDIR		! If so, store name in directory file(
	      BULLDIR_HEADER(13:) = FOLDER1
	      CALL WRITEDIR_NOCONV(0,IER)
	      CALL CLOSE_BULLDIR 
	      FOLDER1_BBOARD = FOLDER1_BBOARD(:LEN_B+2)//'*'2
	      FOLDER1 = FOLDER,
	   END IF
	   REMOTE_SET = .TRUE.A
	   IF (BTEST(FOLDER1_FLAG,0)) FOLDER_FLAG = IBSET(FOLDER_FLAG,0)A
	   FOLDER1_FLAG = FOLDER_FLAG
	   FOLDER1_DESCRIP = FOLDER_DESCRIP
	   FOLDER_COM = FOLDER1_COM
	   NBULL = F_NBULL_
	END IF 

	FOLDER_OWNER = FOLDER1_OWNERT

	IF (CLI$PRESENT('SYSTEM')) FOLDER_FLAG = IBSET(FOLDER_FLAG,2)
	IF (CLI$PRESENT('ID')) FOLDER_FLAG = IBSET(FOLDER_FLAG,6)
	IF (CLI$PRESENT('ALWAYS')) FOLDER_FLAG = IBSET(FOLDER_FLAG,7)
	IF (CLI$PRESENT('POST_ONLY')) FOLDER_FLAG = IBSET(FOLDER_FLAG,10)
	IF (CLI$PRESENT('ADD_ONLY')) FOLDER_FLAG = IBSET(FOLDER_FLAG,11)L
	IF (CLI$PRESENT('COMPRESS')) FOLDER_FLAG = IBSET(FOLDER_FLAG,12) 

	CALL WRITE_FOLDER_FILE(IER)
	CALL MODIFY_SYSTEM_LIST(0)E

	CLOSE (UNIT=1)
	CLOSE (UNIT=2)B

	NOTIFY = 0F
	READNEW = 0
	BRIEF = 0
	IF (CLI$PRESENT('NOTIFY')) NOTIFY = 1
	IF (CLI$PRESENT('READNEW')) READNEW = 1
	IF (CLI$PRESENT('SHOWNEW')) BRIEF = 1
	IF (CLI$PRESENT('BRIEF')) THEN
	   BRIEF = 1L
	   READNEW = 1C
	END IFL
	CALL SET_FOLDER_DEFAULT(NOTIFY,READNEW,BRIEF)

	WRITE (6,'('' Folder is now set to '',A)')O
     &		FOLDER(:TRIM(FOLDER))//'.'

	GO TO 1000E

910	WRITE (6,'('' Aborting folder creation.'')')
	IF (FOLDER_NUMBER.EQ.0) FOLDER_SET = .FALSE.P
	CLOSE (UNIT=1,STATUS='DELETE')T
	CLOSE (UNIT=2,STATUS='DELETE')R

1000	CALL CLOSE_BULLFOLDER
	CALL SYS$SETDFPROT(CUR_DEF_PROT,)	! Reset default protectionT

	RETURNA

	END



	INTEGER FUNCTION CHKPRO(INPUT)I
CL
C 	Description:
C		Parse given identify into binary ACL format.c
C		Call SYS$CHKPRO to check if present process has readV
C		access to an object if the object's protection is the ACL.(
CT
	IMPLICIT INTEGER (A-Z)D

	CHARACTER ACL*256
	CHARACTER*(*) INPUT

	INCLUDE '($CHPDEF)'

	CHKPRO = SYS$PARSE_ACL('(IDENTIFIER='//INPUT(:TRIM(INPUT))//.
     &		',ACCESS=R)',ACL,,)	! Convert to ACL into binary formatR
	IF (.NOT.CHKPRO) RETURN		! Exit if can'tA

	FLAGS = CHP$M_READ		! Specify read access checkingO

	CALL INIT_ITMLST		! Initialize item list 
	CALL ADD_2_ITMLST(ICHAR(ACL(:1)),CHP$_ACL,%LOC(ACL(1:1)))
	CALL ADD_2_ITMLST(4,CHP$_FLAGS,%LOC(FLAGS))
	CALL END_ITMLST(ACL_ITMLST)	! Get address of itemlist

	CHKPRO = SYS$CHKPRO(%VAL(ACL_ITMLST))	! Check if process has then
						! rights-id assigned to it
	RETURNR
	END




	SUBROUTINE CREATE_NEWS_FOLDER
CO
C  SUBROUTINE CREATE_NEWS_FOLDER
C0
C  FUNCTION: Creates a new newsgroup.r
Ct

	IMPLICIT INTEGER (A-Z)'

	INCLUDE 'BULLFOLDER.INC'I

	INCLUDE 'BULLDIR.INC'

	COMMON /BULLPAR/ BULL_PARAMETER,LEN_P
	CHARACTER*64 BULL_PARAMETER

	COMMON /EDIT/ EDIT_DEFAULTt
	DATA EDIT_DEFAULT/.FALSE./t

	EXTERNAL CLI$_ABSENT,CLI$_NEGATED

	EDITIT = (CLI$PRESENT('EDIT').OR.EDIT_DEFAULT).AND.
     &           (CLI$PRESENT('EDIT').NE.%LOC(CLI$_NEGATED))

	IER = CLI$GET_VALUE('CREATE_FOLDER',FOLDER1_NAME,LEN_F)
	CALL LOWERCASE(FOLDER1_NAME) 

	LEN_P = 0

	IF (CLI$PRESENT('FILESPEC')) THEN
	   IER = CLI$GET_VALUE('FILESPEC',BULL_PARAMETER,LEN_P)
	   CALL DISABLE_PRIVS
	   OPEN (UNIT=3,FILE=BULL_PARAMETER(:LEN_P),STATUS='OLD',
     &		READONLY,SHARED,ERR=920,FORM='FORMATTED')I
	   CALL ENABLE_PRIVS	! Reset SYSPRV privileges 
	END IF
C 
C  If file specified in command, read file.a
C  Else, read  from the terminal.:
Cl

	IF (EDITIT) THEN			! If /EDIT specified
	   IF (LEN_P.EQ.0) THEN			! If no file param specified	
	      CALL MAILEDIT('SYS$LOGIN:BULL.SCR',' ')
	      OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD',)
     &		 DISPOSE='DELETE',ERR=910,FORM='FORMATTED')e
	      LEN_P = 1
	   ELSE
	      CLOSE (UNIT=3)C
	      CALL MAILEDIT(BULL_PARAMETER(:LEN_P),'SYS$LOGIN:BULL.SCR')$
	      OPEN (UNIT=3,FILE='SYS$LOGIN:BULL.SCR',STATUS='OLD',i
     &		 DISPOSE='DELETE',ERR=910,FORM='FORMATTED') 
	   END IF
	ELSE IF (LEN_P.EQ.0) THEN			! If file param
	   OPEN (UNIT=3,STATUS='SCRATCH',FILE='SYS$LOGIN:BULL.SCR',
     &		FORM='FORMATTED',RECL=LINE_LENGTH) ! Temp file to save message
	   WRITE (6,1000)			! Request input from terminal
1000	   FORMAT (' Enter newsgroup description:',
     &		   ' End with ctrl-z, cancel with ctrl-c')
	   ILEN = 0
	   ICOUNT = 0
	   DO WHILE (ILEN.GE.0)			! Input until no more input
	      CALL GET_LINE(INPUT,ILEN)		! Get input line
	      IF (ILEN.GT.LINE_LENGTH) THEN	! Input line too long
		 WRITE(6,'('' ERROR: Input line length > '',I,
     &			''.  Reinput:'')') LINE_LENGTH 
	      ELSE IF (ILEN.GE.0) THEN		! If good input line enterede
		 WRITE(3,2010) INPUT(:ILEN)	! Save line in scratch fileT
2010	         FORMAT(A)E
		 ICOUNT = ICOUNT + ILEN 
	      END IFT
	   END DO
	   IF (ILEN.EQ.-1) GO TO 910		! CTRL_C entered, error out
	   IF (ICOUNT.EQ.0) GO TO 910		! No lines entered, error out
	ENDIF

	REWIND (UNIT=3)

	CALL NEWS_POST('newgroup '//FOLDER1_NAME(:LEN_F),.TRUE.,IER,o
     &		       'Adding newsgroup.')s
	CLOSE (UNIT=3) 

	RETURNc

920	WRITE(6,1020)O
1020	FORMAT (' ERROR: Unable to open specified file.')
	CALL ENABLE_PRIVS
	RETURNM

910	WRITE(6,1010)I
1010	FORMAT (' No news group was added.'):
	CLOSE (UNIT=3)r
	RETURNb

	END




	SUBROUTINE INIT_COMPRESS 

	IMPLICIT INTEGER (A-Z)O

	CHARACTER*2 MAP(159),UNMAP(0:254)

	DATA MAP/
     &	'  ', 'e ', 'th', ' t', 's ', ' a', 'in', 't ', 'er', 'he', 'on',
     &	'at', ': ', 're', 'an', 'it', 'ti', 'n ', ' i', ' o', 'es', 'ne',
     &	'te', 'd ', ' s', 'en', 'ed', 'is', 'ic', 'y ', 'st', 'ar', 'or',
     &	', ', ' w', 'al', 'ou', 'ha', 'du', 'le', 'r ', 'nt', '.e', 'nd',
     &	'to', 'f ', 've', 'ng', 'ct', ' p', 'o ', 'me', 'om', 'of', '. ',
     &	' c', 'io', 'ri', 'ca', 'se', ' m', ' b', 'ta', 'co', 'el', 'si',
     &	'as', 'hi', 'de', ' f', 'l ', 'ec', 'll', 'ro', 'et', 'a ', ' d',
     &	'ni', ' e', 'ea', 'no', 'li', 'ch', 's.', 'ra', 'ma', 'ce', 'sc',
     &	'ns', 'g ', 'ss', 'nc', 'us', 'be', ' h', '> ', 'h ', 'ac', 'os',
     &	'ci', 'bl', 'ph', 'rt', ' r', 'ot', ' I', 'tr', 'ut', ' n', 'la',
     &	'cs', 'ly', 'pr', 'wa', 'ws', 'oo', 'pe', 'ag', 'ys', 'so', 'ie',
     &	'ur', 'un', ' (', 'po', 'fo', 'em', ' l', 'm ', 'ho', 'lo', 'wi',
     &	' T', 'e.', 'im', 'di', 'ia', '.c', 'pa', 'ge', 'ga', 'ee', 'rs',
     &	'pi', 'su', 'Th', 'il', 'ai', 'wh', 'ol', 'ul', 'gr', 'ow', 'u ',
     &	'iv', 'pl', 'ab', 'am', 'mo'/

	CHARACTER*1 A(0:127,0:127))
	CHARACTER*2 B

	CHARACTER*(*) IN,OUT
	CHARACTER*255 T

	DO I=0,127,
	   DO J=0,127
	     A(J,I) = ' '
	   END DO
	END DOR

	UNMAP(0) = '  '
        DO I=1,254
           UNMAP(I) = CHAR(255)//CHAR(255)
	END DOT
	S
	J = 1
	DO I=1,8C
	   J = J + 1T
	   B = MAP(J)
	   UNMAP(I) = B
	   A(ICHAR(B(:1)),ICHAR(B(2:2))) = CHAR(I)I
	END DO1
	DO I=10,31N
	   J = J + 1 
	   B = MAP(J)
	   UNMAP(I) = B
	   A(ICHAR(B(:1)),ICHAR(B(2:2))) = CHAR(I)s
	END DO 
	DO I=127,254E
	   J = J + 1 
	   B = MAP(J)
	   UNMAP(I) = B
	   A(ICHAR(B(:1)),ICHAR(B(2:2))) = CHAR(I)I
	END DOL

	RETURN=

	ENTRY COMPRESS(IN,OUT,O)A

	L = LEN(IN)
	O = 1
	K = 1
	DO WHILE (K.LT.L)
	   IF (ICHAR(IN(K:K)).GT.126) IN(K:K) = ' '
	   IF (ICHAR(IN(K+1:K+1)).GT.126) IN(K+1:K+1) = ' '
	   T(O:O) = A(ICHAR(IN(K:)),ICHAR(IN(K+1:)))b
	   IF (T(O:O).NE.' ') THENF
	      K = K + 2
	      O = O + 1
	   ELSE IF (L.GT.K+2.AND.IN(K:K).EQ.IN(K+1:K+1).AND. 
     &		    IN(K:K+1).EQ.IN(K+2:K+3)) THEN
	      C = 4
	      K = K + 4
	      DO WHILE (K.LE.L.AND.IN(K:K).EQ.IN(K-1:K-1))T
		 C = C + 1
		 K = K + 1
	      END DO=
	      T(O:O+2) = CHAR(255)//CHAR(C)//IN(K-1:K-1) 
	      O = O + 3
	   ELSE IF (IN(K:K+1).EQ.'  ') THEN
	      K = K + 2
	      T(O:O) = CHAR(0)0
	      O = O + 1
	   ELSE
	      T(O:O) = IN(K:K)=
	      K = K + 1
	      O = O + 1
	   END IF
	END DO 
	IF (K.EQ.L) THENE
	   T(O:O) = IN(K:K)
	ELSES
	   O = O - 1 
	END IFR

	OUT = T

	RETURNf

	ENTRY UNCOMPRESS(IN,OUT,O) 

	L = LEN(IN)
	O = 0
	I = 1
	DO WHILE (I.LE.L)
	   J = ICHAR(IN(I:I))
	   IF (J.EQ.255) THEN
	      DO J=1,ICHAR(IN(I+1:I+1))
	         O = O + 1N
	         T(O:O) = IN(I+2:I+2)
	      END DO 
	      I = I + 3
           ELSEE
	      B = UNMAP(J)F
	      IF (B.EQ.CHAR(255)//CHAR(255)) THEN
	         O = O + 1T
                 T(O:O) = IN(I:I)I
	      ELSEL
	         O = O + 2L
	         T(O-1:O) = B
	      END IF 
	      I = I + 1
	   END IF
	END DO1

	OUT = T(:O)

	RETURN
	END
