PROGRAM POSTMASTER C CCC POSTMASTER PROGRAM FOR TSX+ MAIL SYSTEM VERSION 1.13 CCC C**************************************************************************** CCC CCC V 1.0 Feb 23/87 First version. CCC V 1.2A Feb 25/87 Cleanup. Change TYPE to WRITE. Make version CCC same as MAIL. CCC V 1.3 Feb 23/87 Change in MAIL version. CCC V 1.5 Apr 4/87 Change in MAIL version. CCC V 1.6 Apr 4/87 Add a PAUSE after a List command CCC V 1.6A May 13/87 Add a PAUSE after a List of 15 users CCC V 1.13 Oct /87 Change in MAIL version C**************************************************************************** CCC CCC FEB /87 CCC CCC MIKE MARAK / (with help from DAVID GAUDINE) CCC LOYOLA EMC LAB CCC LOYOLA CAMPUS, CONCORDIA UNIVERSITY CCC AD-532 CCC 7141 SHERBROOKE ST. W. CCC MONTREAL, CANADA CCC (514) 848-3118 CCC C**************************************************************************** CCC CCC This program sets up the directory and mailboxes for MAIL. It will CCC create the mail file (SY:MAIL.XXX - default), and allow the POSTMASTER CCC to ADD/DELETE USERNAMES to the directory. Users MUST have READ/WRITE CCC ACCESS to this file, whether it is on SY: or a user scratch device. CCC This can be done with the Start-up ACCESS command - CCC ACCESS DL0:/READ,DL0:MAIL.XXX ! if MAIL.XXX is on SY: CCC ACCESS DL2: ! if MAIL.XXX is not on SY: CCC ACCESS DL2:MAIL.XXX/READ ! if MAIL.XXX is not on SY: CCC CCC The mail file (MAIL.XXX) is set up as CCC CCC BLOCK 0-2 DIRECTORY CCC BLOCK 3-XXX MAIL BOXES XXX = (#USERS*5)+3 CCC CCC The directory is set up as: ( WORDS ) CCC USERNAME 12 BYTES ! 0 - 5 !! BYTES WITH TRAILING NULLS CCC INDEX 1 WORD ! 6 !! NEVER NEVER NEVER ALTER CCC NULL 1 WORD ! 7 !! UNUSED (RESERVED) CCC CCC Using this setup, there is enough space for 19 mailboxes, CCC although the directory has space for 96 entries. This setup CCC allows for easily extending the size of the mail file (MAIL.XXX). CCC Each user is allocated 5 blocks for their mail. CCC CCC USERNAMES MUST BE IN THE SAME FORMAT AS TSX USERNAMES CCC CCC The mail file directory format should never be altered. Doing so will CCC produce unpredictable results. CCC CCC Command description is: CCC ADD - Checks if the requested name exists in the directory. CCC Searches the directory for the first free USERNAME CCC area. Enters the username there. It then zeros the CCC user's mailbox. CCC DELETE- Removes a USERNAME from the directory. It then zeros CCC the user's mailbox. CCC LIST - Lists all users in the mail system. CCC CREATE- Creates the mail file (SY:MAIL.XXX), if it does not CCC exist. Prompts for DEVICE and FILENAME for the CCC mailfile, and number of users. Then creates the mail CCC file of size ((#USERS*5)+3) (minimum size = 98) CCC EXTEND- Extend the mailfile (SY:MAIL.XXX) size to accomadate CCC more mailboxes CCC QUIT - Exit this program CCC C**************************************************************************** CCC C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A(1)) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC DATA MBUF/1000*"0/ DATA MAIL/.FALSE./ ! Assume no mail DATA LOGON/.FALSE./ ! Assume not just loggon on DATA DELETE/.FALSE./ ! Assume no deletes DATA ICHAN/-1/ CCC C**************************************************************************** C INTEGER*2 FNAM(4) LOGICAL NEW DATA NEW/.FALSE./ C C**************************************************************************** CCC NEW=.FALSE. ! ASSUME NO NEW CREATE CALL FILE(FNAM) ! GET THE MAILFILE NAME 101 WRITE(7,201) CCC CCC Ask what to do CCC 102 IF(ICHAN.LT.0) GO TO 103 ! ANY CHANNELS ACTIVE ICL=CLOSEC(ICHAN) ! CLOSE FIRST IFC=IFREEC(ICHAN) ! YES - FREE THEM IF (IFC.EQ.0) ICHAN=-1 ! RESET CHAN 103 WRITE(7,202) CCC CCC Get a response CCC CALL GETIN ! Get something IF (INPUT.EQ.'A') GO TO 300 IF (INPUT.EQ.'D') GO TO 300 IF (INPUT.EQ.'L') GO TO 300 IF (INPUT.EQ.'C') GO TO 310 IF (INPUT.EQ.'E') GO TO 320 IF (INPUT.EQ.'Q') GO TO 998 GO TO 102 C 300 IF (ICHAN.GE.0) GO TO 309 ! CHANNEL ALREADY OPEN CALL OPENMF(NEW,0,FNAM) ! Check that the mailfile exists 309 IF (INPUT.EQ.'A') GO TO 301 IF (INPUT.EQ.'D') GO TO 302 IF (INPUT.EQ.'L') GO TO 303 301 CALL ADDUSR ! ADD a new USERNAME GO TO 102 302 CALL DELUSR ! DELETE a USERNAME GO TO 102 303 CALL LSTUSR ! LIST all USERNAMEs PAUSE ! V1.6 GO TO 102 C 310 NEW=.TRUE. CALL CREATE(NEW,FNAM) ! CREATE the mailfile NEW=.FALSE. GO TO 102 C 320 WRITE(7,391) GO TO 102 C 330 GO TO 102 ! NULL OPTION C 340 GO TO 102 ! NULL OPTION C 998 WRITE(7,999) 990 CALL EXIT C 201 FORMAT('0',' POSTMASTER V1.13 LOYOLA EMC LAB',/) 202 FORMAT('0',' Do you want to :',/, + ' A - Add a new user to the mail system',/ + ' D - Delete a current user from the mail system',/, + ' L - List the current users on the mail system',/, + ' C - Create a new system mail file',/, + ' E - Extend the size of the system mail file',/, + ' Q - Exit this program',//, + ' Enter your option : ',$) 391 FORMAT('0',' Use the monitor command "DUP DDn:filnam.ext=/T:n/Y"', + /,' Where "filnam.ext" is the system mail file, and', + /,' "DDn" is the device name containing the mail file',/) 999 FORMAT('0') C END CCC C*************************************************************************** CCC SUBROUTINE GETIN C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC C C Get a character from the tty C 800 READ(5,100,END=31,ERR=30) WTMAIL WTMAIL(81)="0 ! LAST NULL CALL TRIM(WTMAIL) ! REMOVE TRAILING BLANKS INPUT=WTMAIL(1) ! SAVE THE FIRST CHARACTER RETURN C 30 WRITE(7,101) !INPUT ERROR (SHOULD NEVER BE) GO TO 800 31 WRITE(7,102) ! ^Z TERMINATOR (NOT ALLOWED) GO TO 800 C 100 FORMAT(81A1) 101 FORMAT(' ',' INPUT ERROR - RETYPE LINE') 102 FORMAT(' ',' DO NOT USE ^Z - RETYPE LINE') C END CCC C*************************************************************************** CCC SUBROUTINE CREATE(NEW,FNAM) C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** C INTEGER*2 FNAM(4) LOGICAL*1 FDESC(12) LOGICAL NEW C C**************************************************************************** C C C DATA FNAM/3RSY ,3RMAI,3RL ,3RXXX/ DATA FDESC/12*' '/ C C**************************************************************************** CCC C 1 DO 2 J=1,12 FDESC(J)=' ' 2 CONTINUE WRITE(7,100) ! NEW FILE ? Yes or No CALL GETIN IF (INPUT.EQ.'Y') GO TO 110 WRITE(7,101) ! NO - RETURN RETURN C 110 CONTINUE ! YES - PROCEDE C 140 IUSERS=19 ! DEFAULT # USERS WRITE(7,141) ! HOW MANY USERS? READ(5,142,END=143,ERR=140) IUSERS 143 IF(IUSERS.LE.19) IUSERS=19 ! MIN = 19 IF(IUSERS.GE.96) IUSERS=96 ! MAX = 96 IFSIZE=IUSERS*5+3 ! FILE SIZE C 150 CALL R50ASC(12,FNAM,FDESC) WRITE(7,151) (FDESC(J),J=1,12),IFSIZE ! LAST CHANCE CALL GETIN ! YES OR NO IF (INPUT.NE.'Y') GO TO 1 C CALL OPENMF(NEW,IFSIZE,FNAM) ! OPEN THE NEW FILE C IMBLK=0 ! START AT BLK 0 DO 180 K=1,256*3 ! ZERO THE DIRECTORY IOFSET(K)="0 180 CONTINUE INDX=3 ! FIRST BOX AT BLOCK 3 DO 181 K=7,256*3,8 ! SET UP INDEX POINTERS IOFSET(K)=INDX INDX=INDX+5 ! EACH BOX 5 BLOCKS 181 CONTINUE CALL WTBLK(3) ! WRITE DIRECTORY DO 182 J=3,IFSIZE-1 ! DO REST OF FILE IMBLK=J ! BLOCK POINTER DO 183 K=1,256 ! 1 BLOCK AT A TIME IOFSET(K)="0 ! NULLS 183 CONTINUE CALL WTBLK(1) ! WRITE A BLOCK 182 CONTINUE C I=CLOSEC(ICHAN) ! MAKE FILE PERMANENT I=IFPROT(ICHAN,FNAM,1) ! PROTECT FILE I=CLOSEC(ICHAN) ! CLOSE AGAIN IF(I.EQ.-4) STOP ' ERROR - PROTECTED FILE ALREADY EXISTS' I=IFREEC(ICHAN) ! RELEASE CHAN ICHAN=-1 C RETURN C 100 FORMAT(' ',' CREATE A NEW SYSTEM MAILFILE - ARE YOU SURE ? ',$) 101 FORMAT(' ',' CREATE ABORTED') 141 FORMAT(' ',' NUMBER OF USERS (19-96) [19] ? ',$) 142 FORMAT(I2) 151 FORMAT(' ',' A NEW MAILFILE "'12A1,'" OF SIZE ', + I3,' WILL BE CREATED. IS THIS CORRECT ? ',$) C END CCC C*************************************************************************** CCC SUBROUTINE ADDUSR C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** LOGICAL*1 WWNAME(12) DATA WWNAME/12*' '/ C**************************************************************************** CCC C WRITE(7,998) CALL GETNAM ! GET THE USERNAME IF(WUNAME(1).EQ."0) GO TO 40 ! NULL NAME ? CALL CHKDIR ! DOES USERNAME ALREADY EXIST IF (.NOT.UNAME) GO TO 100 ! NO - PROCEDE TO ADD IT IN DO 10 J=1,12 WWNAME(J)=WUNAME(J) IF(WWNAME(J).EQ."0) WWNAME(J)="40 10 CONTINUE WRITE(7,999) (WWNAME(J),J=1,12) RETURN C 100 DO 11 J=1,12 WWNAME(J)=WUNAME(J) ! SAVE THE USERNAME WUNAME(J)="0 ! LOOK FOR THE FIRST NULL 11 CONTINUE CALL CHKDIR ! SEARCH DIRECTORY DO 12 J=1,12 A(IPOS+J-1)=WWNAME(J) ! WRITE THE USERNAME 12 CONTINUE C CALL WTBLK(1) ! WRITE THE BLOCK TO DISK C ! WTBLK WILL ENCRYPT THE BLOCK IMBLK=-(IOFSET(((IPOS-1)/2)+7)) ! UNENCRYPT USER'S MAILBOX DO 30 J=1,1280 IOFSET(J)="0 ! INITIALIZE TO NULLS 30 CONTINUE CALL WTBLK(5) ! START WITH AN EMPTY BOX RETURN C 40 WRITE(7,850) ! NULL NAME MESSAGE RETURN C 998 FORMAT(' ',' USERNAME TO ADD ? ',$) 999 FORMAT(' ',' USERNAME ',12A1,' EXISTS IN DIRECTORY. CANNOT ADD', + ' THIS USERNAME.',/) 850 FORMAT(' ',' CANNOT ADD A NULL NAME.',/) C END CCC C*************************************************************************** CCC SUBROUTINE DELUSR C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** LOGICAL*1 WWNAME(12) DATA WWNAME/12*' '/ C**************************************************************************** CCC C WRITE(7,800) ! ASK FOR USERNAME CALL GETNAM ! GET THE NAME IF (WUNAME(1).EQ."0) GO TO 20 ! NULL NAME CALL CHKDIR ! USER EXISTS? DO 31 J=1,12 ! CONVERT "0 TO ' ' WWNAME(J)=WUNAME(J) ! AND SAVE IF(WWNAME(J).EQ."0) WWNAME(J)="40 ! THE NAME 31 CONTINUE IF (.NOT.UNAME) GO TO 30 WRITE(7,810) (WWNAME(J),J=1,12) ! LAST CHANCE TO CALL GETIN ! ABORT BEFORE DEL. IF(INPUT.NE.'Y') GO TO 40 ! NAME NOT DELETED DO 10 J=1,12 A(IPOS+J-1)="0 ! ZERO THE USERNAME 10 CONTINUE CALL WTBLK(1) ! WRITE UPDATE IMBLK=-(IOFSET(((IPOS-1)/2)+7)) ! GET ADDRESS DO 11 J=1,1280 IOFSET(J)="0 ! ZERO MAILBOX 11 CONTINUE CALL WTBLK(5) ! WRITE EMPTY BOX RETURN C 20 WRITE(7,820) ! DELETE A NULL ???? RETURN ! QUIT COMMAND C 30 WRITE(7,830) (WWNAME(J),J=1,12) RETURN C 40 WRITE(7,840) RETURN C 800 FORMAT(' ',' USERNAME TO DELETE ? ',$) 810 FORMAT(' ',' DELETE ',12A1,' ARE YOU SURE ? ',$) 820 FORMAT(' ',' CANNOT DELETE A NULL NAME',/) 830 FORMAT(' ',' USERNAME ',12A1,' DOES NOT EXISTS IN DIRECTORY.', + ' CANNOT DELETE THIS USERNAME.',/) 840 FORMAT(' ',' DELETE ABORTED BY USER REQUEST',/) C END CCC C*************************************************************************** CCC SUBROUTINE LSTUSR C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC C ITOT=0 IMBLK=0 C WRITE(7,100) ! WRITE A HEADING C CALL RDBLK(3) ! READ THE DIRECTORY DO 200 J=1,(256*2*3),16 ! SCAN THE DIRECTORY IF (A(J).EQ."0) GO TO 200 ! ENTRY NOT NULL ("0) ITOT=ITOT+1 ! INC. TOTAL COUNTER WRITE(7,101) IOFSET((J-1)/2+7),(A(K),K=J,J+11) IF(MOD(ITOT,15).EQ.0) PAUSE 'More users to list' 200 CONTINUE C WRITE(7,103) WRITE(7,102) ITOT C RETURN C 100 FORMAT('0',' ADDRESS USERNAME',/) 101 FORMAT(' ',3X,I3,10X,12A1,$) 102 FORMAT(' ',' There are ',I3,' current users on the mail system',/) 103 FORMAT(' ',' ') C END CCC C*************************************************************************** CCC SUBROUTINE CHKDIR C INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC C C This routine verifies that the requested username exists in the mail C directory, and finds the starting block for the requested USERNAME C in the file MAIL.XXX C UNAME=.FALSE. C DO 12 IBLOCK=1,3 ! SCAN THE DIRECTORY IMBLK=IBLOCK-1 ! BLOCKS 1,2,3 CALL RDBLK(1) C C DO 10 J=1,512,16 DO 11 K=1,12 ! FIND EACH USERNAME IF (WUNAME(K).NE.A(J-1+K)) GO TO 10 11 CONTINUE UNAME=.TRUE. ! USERNAME FOUND CCDD IMBLK=IOFSET(((J-1)/2)+7) ! GET THE BLOCK # IPOS=J ! POINT TO ENTRY GO TO 13 10 CONTINUE C 12 CONTINUE ! NEXT DIR. BLOCK C 13 CONTINUE RETURN END CCC C**************************************************************************** CCC SUBROUTINE RDBLK(NBLK) CCC CCC Read the specified number of blocks of user mail file into memory CCC INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A(1)) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC C ICODE=IREADW((256*NBLK),IOFSET,IMBLK,ICHAN) IF(ICODE.LT.0) GO TO 999 DO 10 J=1,256*NBLK ! IOFSET(J)=-(IOFSET(J)) ! UN-ENCRYPT 10 CONTINUE ! C RETURN C 999 WRITE(7,800) ICODE 800 FORMAT(' ',' ERROR READING MAIL FILE - ERRCODE = ',I3) CALL EXIT END CCC C**************************************************************************** CCC SUBROUTINE WTBLK(NBLK) CCC CCC Write the specified number of blocks of the user mail file to disk CCC INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A(1)) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** CCC DO 10 J=1,256*NBLK ! IOFSET(J)=-(IOFSET(J)) ! ENCRYPT 10 CONTINUE ! C ICODE=IWRITW((256*NBLK),IOFSET,IMBLK,ICHAN) IF(ICODE.LT.0) GO TO 999 C RETURN C 999 WRITE(7,800) ICODE 800 FORMAT(' ',' ERROR WRITING MAIL FILE - ERRCODE = ',I3) CALL EXIT END CCC CCC C**************************************************************************** CCC SUBROUTINE OPENMF(NEW,IFSIZE,FNAM) CCC CCC Open the system mail file for R/W to the file CCC INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A(1)) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** C INTEGER*2 FNAM(4) ! SYSTEM MAIL FILE (RAD50) LOGICAL*1 OUTASC(12) ! ASCII FOR WRITES LOGICAL NEW C C**************************************************************************** C IF (ICHAN.GE.0) GO TO 10 ! CHANNEL ALLOCATED ? ICHAN=IGETC() ! OPEN A CHANNEL IF (ICHAN.LT.0) GO TO 80 ! NO CHANNEL ? IFCH=IFETCH(FNAM) ! LOAD HANDLER IF (IFCH.NE.0) GO TO 81 ! FETCH ERROR ? IF (.NOT.NEW) GO TO 2 ! NEW MAIL FILE ? IPR=IFPROT(ICHAN,FNAM,0) ! CLEAR PROTECTION BIT(IF SET) 3 I=IENTER(ICHAN,FNAM,IFSIZE) ! CREATE A NEW FILE RETURN ! 2 ILOOK=LOOKUP(ICHAN,FNAM) ! IF (ILOOK.LT.0) GO TO 82 ! LOOKUP ERROR ? C 10 RETURN ! ALL OK (so far) C 80 WRITE(7,801) ICHAN STOP 81 WRITE(7,811) IFCH STOP 82 WRITE(7,821) ILOOK STOP C 801 FORMAT('0',' NO CHANNEL AVAILABLE - ICHAN = ',I3,/) 811 FORMAT('0',' HANDLER FETCH ERROR - FETCH CODE = ',I3,/) 821 FORMAT('0',' LOOKUP ERROR = ',I3,' - MAILFILE PROBABLY NOT ', + 'ON DISK',/,' CREATE THE MAILFILE FIRST OR CHECK THE FILE ', + 'SPECIFICATION IN "FILE.FOR"',/) C END CCC CCC C**************************************************************************** CCC SUBROUTINE GETNAM CCC CCC Get a USERNAME CCC INTEGER*2 ILIN,IERR,ISTS,IRET,ICTIM,ICHAR,IOFSET(1280) INTEGER*2 IMBLK, IMNO, INEXT, IMEND, IPUT, ICHAN, IPOS LOGICAL*1 A(2560), WUNAME(12), RUNAME(12), WTMAIL(81), INPUT LOGICAL*1 MBUF(1000) LOGICAL UNAME, LOGON, MAIL, DELETE C EQUIVALENCE (IOFSET, A(1)) C COMMON /MAIL1/ILIN, IERR, ISTS, IRET, ICTIM, ICHAR, + UNAME, IMBLK, LOGON, IMNO,INEXT,IMEND, MAIL, IPUT, + ICHAN, DELETE, IPOS COMMON /MAIL2/A, WUNAME, RUNAME, WTMAIL, INPUT, MBUF CCC C**************************************************************************** C DO 10 J=1,81 WTMAIL(J)="0 ! Reset WTMAIL to NULLS 10 CONTINUE CALL GTLIN(WTMAIL) ! Get a USERNAME DO 11 J=1,12 WUNAME(J)=WTMAIL(J) ! Move it 11 CONTINUE C RETURN END