C C SEND MAIL VIA NETWORK MAIL SERVER C COPYRIGHT (C) 1980, DIGITAL EQUIPMENT CORP. C C JOHN R. COVERT C DIMENSION ISTATB(2) EQUIVALENCE(ISTATB,ISTAT) COMMON/GETNXC/T2LINE,LENT2,ICOMMA LOGICAL*1 CONBLK(72),ADDR(132),TOLINE(132),T2LINE(132),LOC(6) LOGICAL*1 USER(14) LOGICAL SENDFL,EXPAND,MLIST,NEEDRB LOGICAL*4 TRACE DATA EXPAND/.TRUE./ C LUN USAGE C 1 - NETWORK C 2 - LOGICAL LINK C 3 - INPUT FILE TO SEND C 4 - NODE NAME HELP FILE C 7 - MAILING LIST -- AND MAILUSER (ONLY NO LIST) C C ATTACH INPUT TERMINAL C CALL WTQIO("1400,5) ! I DON'T REALLY CARE ABOUT ERRORS C C LOOK AT THE COMMAND LINE (FOR A FILE TO SEND) C CALL GETMCR(ADDR,N) IF(N.LE.4)GO TO 41 DO 40 I=1,N 40 IF(ADDR(I).EQ.' ')GO TO 50 C WE DID NOT FIND A SPACE; THEREFORE, THERE IS NO FILE NAME 41 SENDFL=.FALSE. GO TO 100 C C WE HAVE A FILE NAME, TRY TO OPEN IT C 50 CALL ASNLUN(3,'SY',0) ! FOR DEFAULT. CAN'T FAIL. ADDR(N+1)=0 CALL ADDEXT(ADDR(I+1),'.TXT') OPEN(UNIT=3,TYPE='OLD',NAME=ADDR(I+1),READONLY,ERR=1200) SENDFL=.TRUE. C 100 CONTINUE C C DECLARE US A NETWORK TASK C CALL OPNNTW(1,ISTAT,,,4) IF(ISTAT.EQ.1)GOTO 120 WRITE(5,106) 106 FORMAT(' The network is not currently accessible.') GO TO 1200 C C GET LOCAL NODE NAME C 120 LOCLEN=6 CALL GLNNTW(ISTAT,LOCLEN,LOC) C C GET USER NAME FROM ACCOUNTING, IF POSSIBLE C CALL GINUAB(ADDR,ISTAT) USER(1)=' ' IF(ISTAT.NE.1)GO TO 122 ! GO IF ACCOUNTING FAILED DO 121 I=1,14 121 USER(I)=ADDR(I+68) WRITE(5,1211)USER 1211 FORMAT(' From: ',14A1) 122 CONTINUE C C PROMPT FOR ADDRESSEE C WRITE(5,123) 123 FORMAT(' To: ',$) READ(5,124,END=800)N,TOLINE 124 FORMAT(Q,132A1) IF(N.EQ.0)GO TO 800 C UPCASE THE ADDRESSEE CALL UPCASE(TOLINE,N) C C SAVE TOLINE IN T2LINE FOR FUTURE USE C LENT2=N DO 127 I=1,132 127 T2LINE(I)=TOLINE(I) C C SCAN OFF SPACES C DO 130 I=1,N 130 IF(TOLINE(I).NE.' ')GO TO 131 GO TO 800 !ALL SPACES, QUIT 131 INODE=I C C IF FIRST CHARACTER IS AN @, SETUP MAILING LIST PROCESSING C ALSO SET UP IMMEDIATE MODE MAILING LIST IF COMMAS ARE FOUND C MLIST=.FALSE. ICOMMA=0 IF(TOLINE(INODE).EQ.'@')GO TO 13202 NEEDRB=.FALSE. DO 132 J=I,N IF(TOLINE(J).EQ.'[')NEEDRB=.TRUE. !HAVE LEFT, NEED RT IF(TOLINE(J).EQ.']')NEEDRB=.FALSE. IF(NEEDRB)GO TO 132 IF(TOLINE(J).EQ.',')GO TO 13201 132 CONTINUE GO TO 134 !NO COMMA, SINGLE USER 13201 ICOMMA=I GO TO 133 ! WE HAVE FLAGGED LOCAL LIST 13202 TOLINE(N+1)=0 ! PLUG END FOR OPEN CALL ASNLUN(7,'SY',0) ! FOR DEFAULT. CAN'T FAIL. CALL ADDEXT(TOLINE(INODE+1),'.DIS') OPEN(UNIT=7,TYPE='OLD',NAME=TOLINE(INODE+1),READONLY,ERR=1200) 133 MLIST=.TRUE. INODL=0 GO TO 136 ! CONNECT TO LOCAL SERVER C C SCAN FOR COLON -- HANDLING SINGLE USER CASE C 134 CALL SCANCO(TOLINE,I,INODE,INODL,N) C C IF THERE IS NO NODE NAME (INODL=0) SEE IF THE MAILUSER FILE C GIVES US ONE C IF(INODL.EQ.0)CALL MAIUSR(TOLINE,I,INODE,INODL,N) C C BUILD CONNECT BLOCK C 136 DO 140 J=1,72 140 CONBLK(J)=0 CALL BACC(ISTAT,CONBLK) IF(INODL.NE.0)CALL BFMT0(ISTAT,CONBLK,INODL,TOLINE(INODE),27) IF(INODL.EQ.0)CALL BFMT0(ISTAT,CONBLK,LOCLEN,LOC,27) IF(MLIST)GO TO 161 C C SCAN TOLINE PAST COLONS AND SPACES C CALL SCANEN(TOLINE,I,N,IADDR1,IAD1L) C C CONNECT TO MAIL RECEIVER C 161 CALL CONNTW(2,ISTAT,CONBLK) TRACE='CONN' IF(ISTAT.EQ.1)GOTO 185 ! SUCCESS WITH GIVEN NAME C C WHAT KIND OF ERROR WAS IT C IF(.NOT.(ISTAT.EQ.-7.AND.(ISTATB(2).EQ.2.OR.ISTATB(2).EQ.39))) 1GO TO 870 C C ERROR IS NO SUCH NODE OR UNREACHABLE, SEE IF IT'S IN OUR FILE C UNLESS WE ALREADY DID C IF(.NOT. EXPAND)GOTO 870 164 CALL EXPANS(T2LINE,TOLINE,INODL,INODE,IADDR1,IAD1L,J,IE) IF(IE.NE.0)GOTO 870 EXPAND=.FALSE. C C WE SUCCESSFULLY EXPANDED, GO BACK AND TRY TO CONNECT TO NEW NAME C I=1 N=J-1 GO TO 131 C C COME HERE AFTER CONNECT IS SUCCESSFULL C 185 CONTINUE ICOUNT=0 IECOUN=0 C C SEND MY USER NAME C 187 IF(USER(1).NE.' ')GO TO 190 WRITE(5,189) ! NO ACCOUNTING, PROMPT FOR IT 189 FORMAT(' From: ',$) READ(5,124,END=800)J,USER CALL UPCASE(USER,14) GO TO 187 ! MAKE HIM ENTER IT 190 CALL SNDNTW(2,ISTAT,14,USER) TRACE='SUSE' IF(ISTAT.EQ.1)GO TO 200 WRITE(5,199) 199 FORMAT(' An obscure error has occurred, try again.') GOTO 900 C C SEND ADDRESSEE 1 C 201 CALL SFSUBP(IAD1L,TOLINE(IADDR1)) ! USE PRINT ENTRY POINT ICOUNT=ICOUNT+1 ! MLIST BACK-LOOP CODE IF(IAD1L.LE.0)IECOUN=IECOUN+1 !(ERROR IN IAD1L) 200 IF(MLIST)CALL GETNXA(IAD1L,TOLINE,IADDR1) IF(IAD1L.EQ.0)GO TO 210 CALL SNDNTW(2,ISTAT,IAD1L,TOLINE(IADDR1)) TRACE='SAD1' IF(ISTAT.NE.1)GOTO 900 IF(MLIST)GO TO 201 CALL SFSUB(IERR) IF(IERR.LE.0)GO TO 1300 ICOUNT=1 GO TO 220 C C IF PROCESSING MAILING LIST, CHECK FOR ERRORS C 210 ICOUNT=ICOUNT-IECOUN IF(ICOUNT.EQ.0)GO TO 1300 ! NO ONE TO SEND TO? IF(IECOUN.EQ.0)GO TO 220 ! NO ERRORS 211 WRITE(5,212) 212 FORMAT(/,' Do you want to send to the other addressees', 1' anyway [Y/N]?',$) READ(5,124,END=1200)N,ADDR IF(N.EQ.0)GO TO 1200 CALL UPCASE(ADDR,N) IF(ADDR(1).EQ.'N')GO TO 1200 IF(ADDR(1).NE.'Y')GO TO 211 !ASK AGAIN C C SEND END OF ADDRESSEES C 220 CALL SNDNTW(2,ISTAT,1,0) TRACE='EOAD' IF(ISTAT.NE.1)GOTO 900 C C SEND "TO LINE" AND "SUBJ LINE" C CALL SNDNTW(2,ISTAT,LENT2,T2LINE) TRACE='TEXT' IF(ISTAT.NE.1)GOTO 900 WRITE(5,223) 223 FORMAT(' Subj: ',$) READ(5,124,END=800)N,ADDR IF(N.EQ.0)N=1 ! DECNET M WON'T SEND ZERO LEN CALL SNDNTW(2,ISTAT,N,ADDR) IF(ISTAT.NE.1)GOTO 900 C C SEND TEXT C IUNIT=3 IF(SENDFL)GO TO 300 IUNIT=5 WRITE(5,299) 299 FORMAT(' Enter message below. Type CTRL/Z when done.',/) 300 READ(IUNIT,124,END=400,ERR=380)N,ADDR IF(N.LT.1)N=1 !DECNET CAN'T SEND NULL LENGTH LINES, SO SEND A SPACE 330 CALL SNDNTW(2,ISTAT,N,ADDR) IF(ISTAT.NE.1)GOTO 900 GO TO 300 380 IF(IUNIT.NE.5)GO TO 1200 ! RECOVER ONLY IF TERMINAL ERROR WRITE(5,381) 381 FORMAT(/,' Error reading from terminal; re-type last line.',/) GO TO 300 400 CALL SNDNTW(2,ISTAT,1,0) DO 500 I=1,ICOUNT 500 CALL SFSUB(IERR) 800 CALL EXIT C C CONNECT FAILURES C 870 IF(INODL.NE.0)GOTO 873 INODE=1 INODL=MOVE('local node',TOLINE) 873 ADDR(1)=' ' ! SET UP DEFAULT MESSAGE N=1 ! WHEN N=1 WE USE FORMAT 901 IF(ISTAT.NE.-7)GOTO 875 IF(ISTATB(2).EQ.2) N=MOVE('no such node.',ADDR) IF(ISTATB(2).EQ.3) N=MOVE('node shutting down.',ADDR) IF(ISTATB(2).EQ.39)N=MOVE('node unreachable.',ADDR) IF(ISTATB(2).EQ.4) N=MOVE('slave mail does not exist.',ADDR) IF(ISTATB(2).EQ.6) N=MOVE('slave mail is too busy.',ADDR) IF(ISTATB(2).EQ.38)N=MOVE('slave mail did not respond.',ADDR) 875 WRITE(5,871)(TOLINE(I),I=INODE,INODE+INODL-1),(ADDR(I),I=1,N) 871 FORMAT(' Connection to _',A1,':: failed, ',A1) IF(N.NE.1)GO TO 1200 ! IF DEFAULT MSG, PRINT NUMBERS 900 WRITE(5,901)TRACE,ISTATB 901 FORMAT(1X,A4,' STATUS=',I7,' STATUS2=',I7) 1200 STOP 'ERROR' 1300 CALL SNDNTW(2,ISTAT,1,0) ! END OF LIST, FOR ERROR EXIT GO TO 1200 END C SUBROUTINE SFSUB(IERR,A) DIMENSION ISTATB(2) EQUIVALENCE(ISTATB,ISTAT) INTEGER*4 SFMESS LOGICAL*1 SFTEXT(132),A(132) LEN=0 50 CALL RECNTW(2,ISTAT,4,SFMESS) IF(ISTAT.NE.1)GOTO 900 IERR=1 !SUCCESS IS INDICATED BY IF((SFMESS.AND.1).NE.0)RETURN !THE LOW ORDER BIT BEING SET IERR=-1 !FAILURE C C IF MAILING LIST BEING PROCESSED, PRINT ENTRY C IF(LEN.EQ.0)GO TO 100 ! NOT MAILING LIST WRITE(5,99)(A(I),I=1,LEN) 99 FORMAT(' Error sending to ',2(63A1,/)) C 100 CALL RECNTW(2,ISTAT,132,SFTEXT) IF(ISTAT.EQ.-4)GOTO 200 IF(ISTAT.NE.1)GOTO 900 IF(SFTEXT(1).EQ.0)RETURN 120 WRITE(5,101)(SFTEXT(I),I=1,ISTATB(2)) 101 FORMAT(1X,80A1) GOTO 100 200 IF(SFTEXT(1).EQ.0)RETURN WRITE(5,201) 201 FORMAT(' Error message received from slave mail was too long;' 1,/,' partial message follows:') GO TO 120 C C THIS ENTRY POINT ALLOWS PRINTING OF THE INPUT LINE C FROM A MAILING LIST C ENTRY SFSUBP(IERR,A) LEN=IERR ! SAVE LENGTH GO TO 50 ! AND JOIN REST OF CODE 900 WRITE(5,901)ISTATB 901 FORMAT(' The following fatal error occured while waiting for',/ 1,' a response from the slave mail: RECNT:STATUS=',I7 2,' STATUS2=',I7) STOP 'ERROR' END C SUBROUTINE GETNXA(L,TOLINE,I) COMMON/GETNXC/T2LINE,LENT2,ICOMMA LOGICAL*1 TOLINE(132),T2LINE(132) LOGICAL*1 ADDR(132) LOGICAL NEEDRB 10 IF(ICOMMA)900,100,20 !EOLINE, REAL FILE, NEXT ENTRY C C PROCESS LIST ON TOLINE C 20 L=0 NEEDRB=.FALSE. DO 30 J=ICOMMA,LENT2 !PICK UP ONE ENTRY IF(TOLINE(J).EQ.'[')NEEDRB=.TRUE. !HAVE LEFT, NEED RT IF(TOLINE(J).EQ.']')NEEDRB=.FALSE. IF(NEEDRB)GOTO 29 !DON'T LOOK FOR , YET IF(T2LINE(J).EQ.',')GO TO 35 !GOT IT ALL (& THERE'S MORE) 29 L=L+1 30 TOLINE(L)=T2LINE(J) !MOVE IT OUT ICOMMA=-1 !GOT IT ALL (BUT NO MORE AFTER) 35 IF(ICOMMA.GT.0)ICOMMA=J+1 !WHERE TO START NEXT TIME IF(ICOMMA.GT.LENT2)ICOMMA=-1 !OOPS, NO NEXT TIME IF(L.EQ.0)GO TO 10 !AROUND AGAIN IF NOTHING GO TO 140 100 READ(7,124,END=900)L,TOLINE 124 FORMAT(Q,132A1) IF(L.EQ.0)GOTO 100 IF(TOLINE(1).EQ.';'.OR.TOLINE(1).EQ.'!')GO TO 100 CALL UPCASE(TOLINE,L) C C SCAN OFF SPACES C 140 DO 40 I=1,L 40 IF(TOLINE(I).NE.' ')GO TO 150 !WHEN WE FIND NON-SPACE, GO ON GO TO 10 !ALL SPACES GO AROUND AGAIN 150 INODE=I CALL SCANCO(TOLINE,I,INODE,INODL,L) IF(INODL.EQ.0)GO TO 999 CALL SCANEN(TOLINE,I,L,IADDR1,IAD1L) I=INODE CALL EXPANS(TOLINE,ADDR,INODL,INODE,IADDR1,IAD1L,J,IE) IF(IE.NE.0)GO TO 999 ! DID NOT EXPAND IT L=J-1 ! DID EXPAND, NEW LENGTH DO 200 J=1,L ! COPY NEW STRING OUT 200 TOLINE(J)=ADDR(J) RETURN 900 L=0 999 RETURN END C SUBROUTINE UPCASE(A,N) LOGICAL*1 A(N) DO 125 I=1,N 125 IF(A(I).GE.97.AND.A(I).LE.122)A(I)=A(I)-32 RETURN END C SUBROUTINE EXPANS(INLINE,OUTLIN,INODL,INODE,IADDR1,IAD1L,J,IE) LOGICAL*1 INLINE(132),OUTLIN(132) LOGICAL*1 ADDR(132) COMMON/IOPENA/IOPENA DATA IOPENA/0/ IF(IOPENA.NE.0)GO TO 100 OPEN(UNIT=4,TYPE='OLD',NAME='LB:[1,2]MAILNODE.DAT',READONLY 1,ERR=1200) IOPENA=IOPENA+1 GO TO 165 100 REWIND 4 IE=0 165 READ(4,124,END=162)ILINE,ADDR IF(ADDR(INODL+1).NE.' ')GO TO 165 DO 166,I=1,INODL 166 IF(ADDR(I).NE.INLINE(INODE+I-1))GO TO 165 C C WE HAVE A MATCH, BUILD OUTLIN C J=1 DO 168 I=INODL+2,ILINE OUTLIN(J)=ADDR(I) 168 J=J+1 IF(J+IAD1L.GT.132)GO TO 850 DO 169 I=1,IAD1L OUTLIN(J)=INLINE(IADDR1+I-1) 169 J=J+1 RETURN 162 IE=IE+1 RETURN 850 WRITE(5,851) 851 FORMAT(' Error after parsing address -- address too long.') 1200 STOP 'ERROR' 124 FORMAT(Q,132A1) END C SUBROUTINE SCANCO(TOLINE,I,INODE,INODL,N) LOGICAL*1 TOLINE(N) DO 135 I=INODE,N 135 IF(TOLINE(I).EQ.':')GO TO 136 I=INODE !NO COLON, USE LOCAL 136 INODL=I-INODE !WILL BE ZERO IF LOCAL RETURN END C SUBROUTINE SCANEN(TOLINE,I,N,IADDR1,IAD1L) LOGICAL*1 TOLINE(N) DO 150 I=I,N 150 IF(TOLINE(I).NE.':'.AND.TOLINE(I).NE.' ')GO TO 160 WRITE(5,157)(TOLINE(I),I=1,N) 157 FORMAT(' SEN -- A USER NAME IS REQUIRED.',/,1X,132A1) STOP 'ERROR' 160 IADDR1=I !START OF ADDRESSEE 1 IAD1L=N-I+1 !LENGTH OF ADDRESSEE 1 RETURN END C FUNCTION MOVE(A,B) LOGICAL*1 A(132),B(132) I=0 100 MOVE=I I=I+1 IF(A(I).EQ.0)RETURN ! NULL TERMINATES THE MOVE B(I)=A(I) GO TO 100 END C C ADDEXT -- ADD EXTENSION TO FILE NAME, IF NEEDED C SUBROUTINE ADDEXT(A,EXT) LOGICAL*1 A(132),EXT(132) DO 100 I=1,132 IF(A(I).EQ.'.')RETURN ! ALREADY HAVE EXTENSION IF(A(I).EQ.0)GO TO 200 ! FOUND END 100 CONTINUE RETURN ! CAN'T REALLY GET HERE 200 I=I+MOVE(EXT,A(I)) ! TACK ON EXTENSION A(I)=0 ! PLUG NEW END RETURN END C SUBROUTINE MAIUSR(TOLINE,I,INODE,INODL,N) LOGICAL*1 TOLINE(N) LOGICAL*1 USRREC(132) OPEN(UNIT=7,TYPE='OLD',NAME='LB:[1,2]MAILUSER.DAT',READONLY 1,ERR=1200) 100 READ(7,124,END=800)NU,USRREC 124 FORMAT(Q,132A1) IF(NU.LE.1)GO TO 100 C C FIND THE "->" IN MAILUSER C DO 150 J=1,NU-1 150 IF(USRREC(J).EQ.'-'.AND.USRREC(J+1).EQ.'>') GO TO 200 C C RECORD HAS NO "->", IT'S A COMMENT, IGNORE IT. C GO TO 100 C C IF IT IS AT THE BEGINNING OF THE LINE, ITS AN ERROR C 200 J=J-1 IF(J.EQ.0)GO TO 225 C C COMPARE LEFT SIDE WITH SUPPLIED NAME C IF(N-INODE+1.NE.J)GO TO 100 DO 220 K=1,J 220 IF(USRREC(K).NE.TOLINE(INODE+K-1))GO TO 100 C C WE HAVE A MATCH. REPLACE IT ALL AFTER CHECKING FOR ERR MSGS C IF(USRREC(J+3).NE.'(')GO TO 240 225 WRITE(5,230)(TOLINE(K),K=INODE,N),(USRREC(K),K=J+3,NU) 230 FORMAT(' ?SEND -- "'A1,'"',72A1) GO TO 1200 240 CALL SCANCO(USRREC,JUNK,J+3,K,NU) IF(K.EQ.0)GO TO 800 ! NO NODE NAME, DON'T CHANGE I=1 INODE=1 DO 250 K=J+3,NU TOLINE(I)=USRREC(K) 250 I=I+1 N=NU-(J+2) CALL SCANCO(TOLINE,I,INODE,INODL,N) 800 CLOSE(UNIT=7) RETURN 1200 STOP 'ERROR' END