C C READ MAIL C C COPYRIGHT (C) 1980, DIGITAL EQUIPMENT CORP. C JOHN R. COVERT C PARAMETER MLUN=1 ! THE MAIL FILE (LB:[1,7].......TXT) PARAMETER T1LUN=2 ! TEMPORARY FILE 1 PARAMETER T2LUN=3 ! TEMPORARY FILE 2 PARAMETER SVLUN=4 ! FILE FOR SAVING MAIL PARAMETER LPLUN=6 ! PRINTER PARAMETER POLEN=18 ! LENGTH (W/O NULL) OF PONAME C LOGICAL*1 PONAME(20) ! HOLDS CONSTRUCTED NAME LOGICAL*1 MLNAME(31) ! NAME ACTUALLY IN USE NOW LOGICAL*1 MLDNAM(31) ! DISPLAY NAME INTEGER MLLEN,MLDLEN INTEGER*4 BAGSIZ INTEGER BAGSLO,BAGSHI,BAGSAR(2) EQUIVALENCE(BAGSIZ,BAGSAR),(BAGSLO,BAGSAR),(BAGSHI,BAGSAR(2)) LOGICAL*1 A(134),A2(134)! WORK TEXT ARRAYS COMMON /ACOM/A EQUIVALENCE (A2,A2A),(A2(5),A2B),(A2(9),A2C) EQUIVALENCE(A,NOTIFY) EQUIVALENCE(A,GLUN) INTEGER GLUN(6) EQUIVALENCE(A,A8) REAL*8 A8(17) ! FOR FASTER I/O LOGICAL*4 ISRE EQUIVALENCE(A(11),ISRE) EQUIVALENCE(A,A4) LOGICAL*4 A2A,A2B,A2C LOGICAL READ,QMARK,TFLAG,MEMODE,NODELS,PRINT,POMODE LOGICAL CKCOM C INTEGER SCAN LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG C C COMMON/GCOMC/IGCOMF C INTEGER HIB(500),LOB(500),BYT(500) ! FOR MARK/POINT INTEGER T1LUNH,T1LUNL,T1LUNB C INTEGER IA(6) ! FOR WTQIO COMMON /IACOM/IA LOGICAL*4 MSGHDR(6),A4(34) REAL*8 PRSRTN(5),SAVTHS(2) C C ****** C LOGICAL QBRIE COMMON QBRIE C C ****** C DATA PRSRTN/'Press re','turn to ','read nex','t messag', 1'e.> '/SAVTHS/'Save thi','s mail? '/ DATA MSGHDR/'Netw','ork ','Mail',' rec','eive','d on'/ C DATA SERVNT/6RMAL.../ CALL WTQIO("1400,5,1) !ATTACH TERMINAL PRINT=.FALSE. POMODE=.TRUE. CALL GETTSK(A) IGRP=A(32).AND."377 IPRG=A(31).AND."377 IGRPL=LEN(IGRP,8) ! GET NO OF DIGITS, BASE 8 IPRGL=LEN(IPRG,8) ENCODE(20,1,PONAME)IGRP,IPRG 1 FORMAT('LB:[1,7]000000',T<12-IGRPL>,O,T<15-IPRGL> 1,O,'.TXT') PONAME(POLEN+1)=0 CALL GCOM(READ,QMARK,NOTCTL,NOTIFY,ICMDID,MEMODE) IGCOMF=IGCOMF+1 IF(NOTCTL.EQ.0)GO TO 40 CALL SEND(SERVNT,A) CALL REQUES(SERVNT) 40 CALL ERRSET(29,.TRUE.,.FALSE.,,.FALSE.) CALL ERRSET(30,.TRUE.,.FALSE.,,.FALSE.) IF(ICMDID.EQ.2.AND.INSTR(1).NE."177)GO TO 2305 ! HAVE A NAME ALREADY 44 POMODE=.TRUE. CALL MOVE(PONAME,MLNAME,POLEN+1) ! INITIALLY CALL MOVE('POSTOFFICE',MLDNAM,10) MLDLEN=10 45 IMSGN=0 NODELS=.TRUE. ITRY=0 50 OPEN(UNIT=MLUN,NAME=MLNAME,TYPE='OLD',ERR=800,ACCESS='APPEND') IF(.NOT.QBRIE)GO TO 70 CALL MARK(MLUN,BAGSHI,BAGSLO,N) N=(N+26)/51 IF(N.LT.10)GO TO 54 N=0 GO TO 55 54 BAGSIZ=BAGSIZ-1 55 WRITE(5,60)7,BAGSIZ,N,7 60 FORMAT(1X,A1,'You have ',I,'.',I1, 1' blocks of mail.',A1) CALL EXIT 70 OPEN(UNIT=T1LUN,NAME=MLNAME,TYPE='OLD',READONLY,SHARED) CLOSE(UNIT=MLUN) TFLAG=.TRUE. MLINES=0 MESSAG=0 100 CALL MARK(T1LUN,T1LUNH,T1LUNL,T1LUNB) ! REMEMBER WHERE WE WERE READ(T1LUN,101,END=200)N,A(1) 1001 FORMAT(Q,17A8) 101 FORMAT(Q,134A1) 1002 FORMAT(A8,A) 1003 FORMAT(A) 102 FORMAT(134A1) MLINES=MLINES+1 IF(POMODE)GO TO 104 IF(.NOT.TFLAG)GO TO 120 ! CAN'T BE NEW MESSAGE TFLAG=.FALSE. IF(N.NE.43.OR.A(1).NE.'N')GO TO 120 CALL POINT(T1LUN,T1LUNH,T1LUNL,T1LUNB) ! GET BACK, CLOSER LOOK READ(T1LUN,1001)N,A8 ! AT THE WHOLE THING DO 103 I=1,6 103 IF(A4(I).NE.MSGHDR(I))GO TO 100 GO TO 105 104 IF(A(1).EQ."11.OR.N.NE.43)GO TO 100 105 MESSAG=MESSAG+1 ! NOT TAB, COUNT MSGS HIB(MESSAG)=T1LUNH LOB(MESSAG)=T1LUNL BYT(MESSAG)=T1LUNB GO TO 100 C 1102 FORMAT(A1,A8,A) 1103 FORMAT(A1,A) 120 IF(N.EQ.1.AND.A(1).EQ."14)TFLAG=.TRUE. ! MIGHT BE NEAR NEW MSG GO TO 100 C 222 FORMAT() 242 FORMAT(1X,80A1) 200 IF(MESSAG.EQ.0)GO TO 1300 ! EMPTY HIB(MESSAG+1)=0 LOB(MESSAG+1)=0 BYT(MESSAG+1)=0 I=1 IF(MESSAG.NE.1)I=2 IF(QMARK)WRITE(5,201)7,MESSAG,'es',MLINES,7 201 FORMAT(1X,A1,'You have ',I 1,' messag',A,' in ',I,' lines.',A1) IF(QMARK)CALL EXIT REWIND T1LUN C IBEG=1 IF(POMODE)IBEG=2 IBEGM1=IBEG-1 GO TO 1501 ! NEW COMMANDS ONLY NOW C C C DELETE THE MAIL C 400 IF((.NOT.POMODE).AND.NODELS)GO TO 476 ITRY=0 410 OPEN(UNIT=MLUN,NAME=MLNAME,TYPE='OLD',ERR=480,ACCESS='APPEND') CALL MARK(MLUN,MLUNH,MLUNL,MLUNB) ! LOOK AT END MLINES=0 IF(MLUNH.EQ.T1LUNH.AND.MLUNL.EQ.T1LUNL.AND.MLUNB.EQ.T1LUNB) 1GO TO 425 MLINES=MLINES+1 CLOSE(UNIT=T1LUN) ! RE-OPEN, NEW EOF OPEN(UNIT=T1LUN,NAME=MLNAME,TYPE='OLD',READONLY,SHARED) 425 IF(.NOT.NODELS)GO TO 450 IF(MLINES.EQ.0)GO TO 475 ! END MEANS NOTHING NEW GO TO 473 450 REWIND T1LUN REWIND MLUN IMSGN=1 QMARK=.TRUE. ! TRUE=NOTHING COPIED TO MLUN 460 IF(IMSGN.EQ.0)GO TO 465 CALL MARK(T1LUN,N,I,I1) IF(I.NE.LOB(IMSGN).OR.I1.NE.BYT(IMSGN))GO TO 465 I1=HIB(IMSGN) I=I1.AND."777 IF(I.NE.N)GO TO 465 IMSGN=IMSGN+1 IF(I1.GE.512)GO TO 461 ! DELETED IF(IMSGN.GT.MESSAG)GO TO 464 GO TO 465 461 IF(IMSGN.GT.MESSAG)GO TO 463 ! OFF THE END IF(HIB(IMSGN).LT.512)GO TO 462 IMSGN=IMSGN+1 GO TO 461 462 CALL POINT(T1LUN,HIB(IMSGN),LOB(IMSGN),BYT(IMSGN)) IMSGN=IMSGN+1 IF(IMSGN.GT.MESSAG)GO TO 464 GO TO 465 463 CALL POINT(T1LUN,T1LUNH,T1LUNL,T1LUNB) 464 IMSGN=0 465 READ(T1LUN,1001,END=470)N,A8 IF(N.GT.0)GO TO 466 WRITE(MLUN,222) GO TO 467 466 WRITE(MLUN,102)(A(I),I=1,N) 467 QMARK=.FALSE. ! INDICATE SOMETHING WRITTEN GO TO 460 470 IF(QMARK)GO TO 451 ! DIDN'T WRITE ANYTHING, SO DELETE IT IF(MLINES.EQ.0)GO TO 475 473 IF(POMODE)WRITE(5,471) 471 FORMAT(' New mail arrived while you were reading.') 475 CLOSE(UNIT=MLUN) 476 IF(ICMDID.EQ.2)GO TO 2300 CALL EXIT 451 CLOSE(UNIT=MLUN,DISP='DELETE') ! REALLY DELETE IT SINCE WRITE(5,1301)(MLDNAM(I),I=1,MLDLEN),IGRP,IPRG GO TO 476 ! NONE ARRIVED WHILE WE WERE BUSY 480 CALL ERRSNS(NUM,IOERR,IOERR1) IF(NUM.EQ.29)GO TO 1300 ! SHOULDN'T HAPPEN, BUT WHO CARES IF(NUM.NE.30)STOP 'ERROR' IF(IOERR.NE.-29.AND.IOERR.NE.-27)GO TO 1400 ! REALLY CANT OPEN IF(ITRY.GT.3)GO TO 1400 ! TOO LONG IF(ITRY.EQ.0)WRITE(5,850) ! SENSING INC MAIL, WAITING ITRY=ITRY+1 CALL WAIT(3,2) ! THREE SECONDS EACH TIME GO TO 410 ! AND TRY AGAIN C C C C C C 800 CALL ERRSNS(NUM,IOERR,IOERR1) IF(NUM.EQ.29)GO TO 1300 IF(NUM.NE.30)STOP 'ERROR' IF(IOERR.NE.-29.AND.IOERR.NE.-27)GO TO 1400 ! REALLY CANT OPEN IF(ITRY.GT.3)GO TO 1400 ! TOO LONG IF(ITRY.EQ.0)WRITE(5,850) ! SENSING INC MAIL, WAITING ITRY=ITRY+1 CALL WAIT(3,2) ! THREE SECONDS EACH TIME GO TO 50 ! AND TRY AGAIN 850 FORMAT(' Sensing incoming mail, waiting...') 1300 WRITE(5,1301)(MLDNAM(I),I=1,MLDLEN),IGRP,IPRG 1301 FORMAT(' Your mailbox (', 1A1,') is empty. [',O,',',O,']') CALL EXIT 1400 WRITE(5,1401)(MLNAME(I),I=1,18),IOERR 1401 FORMAT(' Unable to open mail file ',18A1,' - I/O Status:',I4,'.') STOP 'ERROR' C C C PROCESS NEW STYLE COMMANDS C 1500 CALL GCOM(READ,QMARK,NOTCTL,NOTIFY,ICMDID,MEMODE) 1501 GO TO (400,2000,3000,3010,3500,4000,5000,5500,6000, 1 7000,1700,4010,4050,4060,3400),ICMDID STOP 'IMPOSSIBLE' C C QUIT COMMAND C 1700 IF(NODELS)CALL EXIT WRITE(5,1701) 1701 FORMAT(' QUIT -- Exited without deleting messages.') CALL EXIT C C C PROCESS "DIR" COMMAND C 2000 IF(INSTR(1).NE."177)GO TO 2200 2001 FORMAT(//,5X,'# From',17X,'Date',9X,'Subject',T55,A1,/) A2(1)=0 ! FLAG TO SEE IF THERE WERE ANY DO 2100 I=1,MESSAG C IF(HIB(I).GE.512)GO TO 2100 ! THIS MESSAGE WAS DELETED IF(A2(1).EQ.0)WRITE(5,2001)(MLDNAM(I1),I1=1,MLDLEN) DO 2010 I1=1,74 2010 A2(I1)=' ' CALL POINT(T1LUN,HIB(I),LOB(I),BYT(I)) READ(T1LUN,1001,END=2100)N,A8 CALL MOVE(A(26),A2(22),9) READ(T1LUN,222,END=2100) ! DISCARD BLANK LINE READ(T1LUN,1001,END=2100)N,A8 QMARK=.FALSE. IF(N.EQ.0)N=1 DO 2015 I1=N,1,-1 ! REMOVE TRAILING SPACES FROM NAME IF(A(I1).NE.' ')GO TO 2016 2015 N=N-1 IF(N.EQ.0)N=1 2016 DO 2020 I1=N,1,-1 ! FIND ORIGIN NODE AND NAME IF(A(I1).NE.':')GO TO 2020 IF(A(I1+1).EQ.' ')GO TO 2025 ! WE FOUND FROM:TEXT IF(A(I1-1).EQ.':'.AND.QMARK)GO TO 2030 ! WE FOUND SECOND :: QMARK=.TRUE. ! INDICATE ONE COLON SEEN 2020 CONTINUE I1=-1 ! SHOULDN'T HAPPEN, BUT CODE WILL WORK 2025 I1=I1+1 2030 I1=I1+1 N=MIN0(N-I1+1,20) ! WE ONLY HAVE ROOM FOR 20 CHARS IF(N.LE.0)N=1 CALL MOVE(A(I1),A2,N) DO 2035 I1=1,N A2(I1)=A2(I1).AND."177 2035 IF(A2(I1).LT.32.OR.A2(I1).GT.126)A2(I1)=32 !BLANK OUT NON-PRINT READ(T1LUN,222,END=2100) ! DISCARD "TO" LINE READ(T1LUN,1001,END=2100)N,A8 ! SUBJECT I1=MIN0(39,N-8-IBEGM1) CALL MOVE(A(9+IBEGM1),A2(34),I1) WRITE(5,2040)I,(A2(I1),I1=1,I1+33) 2040 FORMAT(I6,1X,74A1) 2100 CONTINUE IF(A2(1).EQ.0)WRITE(5,2101) 2101 FORMAT(' You have deleted all of your messages.') GO TO 1500 ! GET NEXT COMMAND C 2200 GO TO 400 ! DELETE WHAT WE NEED TO 2300 CLOSE(UNIT=T1LUN) 2305 CALL ASNLUN(MLUN,'SY',0) CALL ASNLUN(T1LUN,'SY',0) I1=1 QMARK=.FALSE. IF(.NOT.CKCOM('POSTOFFICE',10))GO TO 2308 INSTR(1)="177 GO TO 44 2308 POMODE=.FALSE. 2310 IF(INSTR(1).EQ.'.')QMARK=.TRUE. I=LINSTR CALL MOVE(INSTR,MLNAME(I1),I) I1=I1+I 2320 IF(SCAN().EQ.0)GO TO 2320 IF(INSTR(1).NE."177)GO TO 2310 MLDLEN=I1-1 CALL MOVE(MLNAME,MLDNAM,MLDLEN) IF(QMARK)GO TO 2330 CALL MOVE('.MAI',MLNAME(I1),4) I1=I1+4 2330 MLNAME(I1)=0 MLLEN=I1-1 QMARK=.FALSE. GO TO 45 C C PROCESS READ (3000=NUMBER GIVEN, 3010=PROCESS NEXT) C (3500=BACK) C 3000 IMSGN=INNUM(10) IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)IMSGN=MESSAG 3005 IF(HIB(IMSGN).LT.512)GO TO 3012 WRITE(5,3008),IMSGN 3008 FORMAT(' Message #',I,' has been deleted.') GO TO 1500 3010 IMSGN=IMSGN+1 IF(IMSGN.GT.MESSAG)GO TO 3100 ! NO MORE IF(HIB(IMSGN).GE.512)GO TO 3010 ! DELETED, GO GET NEXT 3012 CALL POINT(T1LUN,HIB(IMSGN),LOB(IMSGN),BYT(IMSGN)) READ(T1LUN,1001,END=1500)N,A8 ! HEADER WRITE(5,3018)(A(I),I=1,N),(MLDNAM(I),I=1,MLDLEN),IMSGN 3018 FORMAT(1X,A1,T55,A1,' #',I) 3020 CALL MARK(T1LUN,N,I,I1) IF(N.EQ.(HIB(IMSGN+1).AND."777).AND.I.EQ.LOB(IMSGN+1).AND. 1I1.EQ.BYT(IMSGN+1))GO TO 1500 READ(T1LUN,1001,END=1500)N,A8 IF(N.EQ.IBEG.AND.A(IBEG).EQ.12)N=IBEGM1 ! DON'T SHOW FORM FEEDS IF(N.EQ.IBEGM1)WRITE(5,222) IF(N.NE.IBEGM1)WRITE(5,242)(A(I),I=IBEG,N) GO TO 3020 3100 WRITE(5,3101) 3101 FORMAT(' No more messages.') IMSGN=0 GO TO 1500 C C CURRENT -- REREAD CURRENT MESSAGE C 3400 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 GO TO 3005 C C BACK C 3500 IMSGN=IMSGN-1 IF(IMSGN.EQ.0)GO TO 3100 ! NO MORE IF(IMSGN.LT.0)IMSGN=MESSAG ! LOOP AROUND THE BACK IF(HIB(IMSGN).GE.512)GO TO 3500 ! DELETED, KEEP BACKING UP GO TO 3012 ! OK, GO DO IT C C THE DELETE COMMAND (4000 DELETE CURRENT, 4010 - DELETE N) C 4000 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 I=IMSGN 4005 IF(HIB(I).GE.512)GO TO 4020 ! IT HAS BEEN DELETED HIB(I)=HIB(I).OR.512 NODELS=.FALSE. GO TO 1500 4010 I=INNUM(10) IF(I.GT.0.AND.I.LE.MESSAGE)GO TO 4005 ! SO FAR, SO GOOD I1=1 WRITE(5,4016)I,'d',MESSAGE 4016 FORMAT(' Message #',I, 1' can not be ',A,'eleted.',/ 1' Valid message numbers are 1 through ', 1 I) GO TO 1500 4020 WRITE(5,4021)I 4021 FORMAT(' Message #',I,' has already been deleted.') GO TO 1500 C C THE UNDELETE COMMAND (4050 UNDELETE CURRENT, 4060 - UNDELETE N) C 4050 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 I=IMSGN 4055 IF(HIB(I).LT.512)GO TO 4070 ! IT HAS NOT BEEN DELETED HIB(I)=HIB(I).AND."377 WRITE(5,4056)I 4056 FORMAT(' Message #',I,' undeleted.') GO TO 1500 4060 I=INNUM(10) IF(I.GT.0.AND.I.LE.MESSAGE)GO TO 4055 ! SO FAR, SO GOOD I1=3 WRITE(5,4016)I,'und',MESSAGE GO TO 1500 4070 WRITE(5,4071)I 4071 FORMAT(' Message #',I,' was not deleted.') GO TO 1500 C C HANDY DANDY MESSAGE C 4100 WRITE(5,4101) 4101 FORMAT(' You aren''t reading a message.') GO TO 1500 C C FILE C 5000 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 IF(HIB(IMSGN).GE.512)GO TO 4100 ! IT HAS BEEN DELETED CALL ASNLUN(SVLUN,'SY',0) ! DEFAULT IS SY I1=1 QMARK=.FALSE. ! PERIOD SEEN 5010 I=SCAN() IF(I.EQ.0)GO TO 5010 IF(INSTR(1).EQ."177)GO TO 5020 IF(INSTR(1).EQ.'.')QMARK=.TRUE. I=LINSTR CALL MOVE(INSTR,A2(I1),I) I1=I1+LINSTR GO TO 5010 5020 IF(I1.EQ.1.OR.A2(I1-1).EQ.']'.OR.A2(I1-1).EQ.':')GO TO 5026 IF(QMARK)GO TO 5028 CALL MOVE('.MAI',A2(I1),4) I1=I1+4 GO TO 5028 5026 CALL MOVE('MAIL.MAI',A2(I1),8) I1=I1+8 5028 A2(I1)=0 N2=I1-1 OPEN(UNIT=SVLUN,TYPE='UNKNOWN',ACCESS='APPEND',NAME=A2 1,CARRIAGECONTROL='LIST',ERR=5080) ILUN=SVLUN 5029 CALL POINT(T1LUN,HIB(IMSGN),LOB(IMSGN),BYT(IMSGN)) READ(T1LUN,1001,END=5090)N,A8 WRITE(ILUN,102)(A(I),I=1,N) 5030 CALL MARK(T1LUN,N,I,I1) IF(N.EQ.(HIB(IMSGN+1).AND."777).AND.I.EQ.LOB(IMSGN+1).AND. 1I1.EQ.BYT(IMSGN+1))GO TO 5090 READ(T1LUN,1001,END=5090)N,A8 IF(N.EQ.IBEGM1)WRITE(ILUN,222) IF(N.NE.IBEGM1)WRITE(ILUN,102)(A(I),I=IBEG,N) QMARK=N.EQ.IBEG.AND.A(IBEG).EQ.12 ! A FORM FEED GO TO 5030 5080 CALL ERRSNS(NUM,IOERR,IOERR1) WRITE(5,5081)(A2(I),I=1,N2),IOERR 5081 FORMAT(' Unable to open ',A1,' - I/O Status',I5,'.') GO TO 1500 5090 IF((.NOT.QMARK).AND.ICMDID.NE.10)WRITE(ILUN,102)12 IF(ILUN.EQ.LPLUN)GO TO 1500 ! KEEP PRINT FILE OPEN CLOSE(UNIT=SVLUN) IF(ICMDID.EQ.10)GO TO 7100 ! CHEAP SUBROUTINE FOR FWD WRITE(5,5091)(A2(I),I=1,N2) GO TO 1500 5091 FORMAT(' Mail saved in file ',134A1) C C PRINT -- MOSTLY USES FILE C 5500 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 IF(HIB(IMSGN).GE.512)GO TO 4100 ! IT HAS BEEN DELETED ILUN=LPLUN IF(PRINT)GO TO 5029 ! ALREADY OPEN CALL ASNLUN(LPLUN,'LP',0,I) IF(I.EQ.1)GO TO 5510 5504 WRITE(5,5505) 5505 FORMAT(' Unable to access the lineprinter.') GO TO 1500 5510 CALL GETLUN(LPLUN,GLUN) IF((GLUN(3).AND."4000).NE.0)GO TO 5515 WRITE(5,5511) 5511 FORMAT(' The PRINT command is only supported on systems with', 1' automatic output spooling.') GO TO 1500 5515 PRINT=.TRUE. OPEN(UNIT=LPLUN,TYPE='NEW',NAME='MAIL.LST' 1,CARRIAGECONTROL='LIST',ERR=5504) GO TO 5029 C C REPLY C 6000 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 IF(HIB(IMSGN).GE.512)GO TO 4100 ! IT HAS BEEN DELETED CALL OPNTMP(GLUN,A2,SVLUN,I) IF(I.NE.0)GO TO 5080 CALL POINT(T1LUN,HIB(IMSGN),LOB(IMSGN),BYT(IMSGN)) READ(T1LUN,222,END=6100) ! DISCARD HEADER READ(T1LUN,222,END=6100) ! DISCARD BLANK LINE READ(T1LUN,1001,END=6100)N,A8 ! FROM LINE IF(N.EQ.0)GO TO 6100 6010 DO 6015 I1=N,1,-1 ! REMOVE TRAILING JUNK FROM NAME A(I1)=A(I1).AND."177 IF(A(I1).GT.' '.AND.A(I1).LT."177)GO TO 6016 6015 N=N-1 GO TO 6100 ! NOTHING ON LINE? 6016 IF(A(I1).NE.'"')GO TO 6020 ! THERE IS NO RSTS NAME STUFF N=N-1 DO 6017 I1=N,1,-1 N=N-1 6017 IF(A(I1).EQ.'"')GO TO 6010 ! END OF RSTS NAME, GO BACK GO TO 6100 ! ONLY ONE QUOTE?? TROUBLE 6020 IF(N.LT.7+IBEGM1)GO TO 6100 ! NOTHING AFTER FROM: ?? WRITE(SVLUN,102)(A(I1),I1=7+IBEGM1,N) READ(T1LUN,222,END=6100) ! DISCARD "TO" LINE READ(T1LUN,1001,END=6100)N,A8 ! SUBJECT CALL MOVE('RE: ',A2,4) I1=MAX0(MIN0(N-9-IBEGM1,128),1) CALL MOVE(A(10+IBEGM1),A2(5),I1) I1=I1+4 N2=0 IF(ISRE.NE.'RE: ')GO TO 6024 N2=4 6024 DO 6025 I=5+N2,I1 6025 IF(A2(I).NE.' ')GO TO 6030 ! NON-BLANK SUBJECT? A2(1+N2)=' ' I1=1 ! BLANK, PASS ONE CHR TO SEND 6030 WRITE(SVLUN,102)(A2(I),I=1+N2,I1) CLOSE(UNIT=SVLUN) CALL SENDRP GO TO 1500 6100 WRITE(5,6101) 6101 FORMAT 1(' Mail file has illegal format -- cannot reply -- use Send.') GO TO 1500 C C FORWARD C 7000 IF(IMSGN.LE.0.OR.IMSGN.GT.MESSAG)GO TO 4100 IF(HIB(IMSGN).GE.512)GO TO 4100 ! IT HAS BEEN DELETED CALL OPNTMP(GLUN,A2,SVLUN,I) IF(I.NE.0)GO TO 5080 DO 7050 N2=1,30 7050 IF(A2(N2).EQ.0)GO TO 7051 7051 N2=N2-1 ILUN=SVLUN GO TO 5029 7100 CALL MOVE('SEND ',A(1),5) CALL MOVE(A2(1),A(6),N2) CALL MCRSUB(N2+5) OPEN(UNIT=SVLUN,TYPE='OLD',NAME=A2,ERR=7110) CLOSE(UNIT=SVLUN,DISP='DELETE') 7110 GO TO 1500 END C C SEND SUBROUTINE - SPAWNS MCR WITH THE COMMAND LINE GIVEN C OR OTHER CLIS C SUBROUTINE MCRSUB(N) LOGICAL*1 A(134) COMMON /ACOM/A LOGICAL*4 MCR,DCL,CLI DATA MCR/6RMCR.../,DCL/6RDCL.../ CLI=MCR 100 IF(N.EQ.0)GO TO 600 CALL WTQIO("2000,5,1) !DETACH TERMINAL CALL SPAWN(CLI,,,1,,,,A,N,,,I) IF(I.EQ.1)GO TO 1000 WRITE(5,500)I 500 FORMAT(' Failed to SPAWN command interpreter -- $DSW=',I5,'.') RETURN 600 WRITE(5,601) 601 FORMAT(' Command is required.') RETURN 1000 CALL STOPFR(1,I) IF(I.EQ.1)GO TO 2000 CALL WAITFR(1) !SYSTEM WITH SPAWN AND NOT STOP? 2000 CALL WTQIO("1400,5,1) !ATTACH TERMINAL RETURN C C DCL C ENTRY DCLSUB(N) CLI=DCL GOTO 100 !JOIN COMMON CODE END C C CREATE A SEND COMMAND LINE AND CALL MCRSUB (FOR SEND AND REPLY) C SUBROUTINE SENDCM C LOGICAL*1 A(134) COMMON /ACOM/A C CALL MOVE('SEND ',A(1),5) ! INITIALIZE COMMAND LINE I=6 2010 CALL MOVCOM(I) CALL MCRSUB(I-1) RETURN C C ENTRY POINT FOR REPLY C ENTRY SENDRP CALL MOVE('SEND/RP ',A(1),8) ! INITIALIZE COMMAND LINE I=9 GO TO 2010 ! JOIN COMMON CODE C C ENTRY POINT FOR MCRCOM C ENTRY MCRCOM I=1 ! JUST WHAT HE'S GOT GO TO 2010 C C ENTRY POINT FOR DCLCOM ENTRY DCLCOM I=1 CALL MOVCOM(I) CALL DCLSUB(I-1) RETURN END C C MOVCOM -- MOVES REST OF COMMAND INTO A AT I C SUBROUTINE MOVCOM(I) INTEGER SCAN LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG C LOGICAL*1 A(134) COMMON /ACOM/A 2010 IF(SCAN().EQ.0)GO TO 2010 ! ELIMINATE FIRST SPACE GO TO 2110 2100 CALL SCAN ! KEEP ALL ELSE AS IS 2110 IF(INSTR(1).EQ."177)RETURN ! END OF LINE ENCOUNTERED N=LINSTR CALL MOVE(INSTR(1),A(I),N) I=I+N GO TO 2100 END C SUBROUTINE GCOM(READ,QMARK,NOTCTL,NOTIFY,ICMDID,MEMODE) LOGICAL READ,QMARK,MEMODE EXTERNAL INSUB LOGICAL CKCOM C INTEGER SCAN LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG C LOGICAL*1 A(134) COMMON /ACOM/A COMMON/GCOMC/IGCOMF C C ****** C LOGICAL QBRIE COMMON QBRIE C C ****** C DATA IGCOMF/0/ NOTCTL=0 QMARK=.FALSE. READ=.TRUE. MEMODE=.FALSE. C IF(IGCOMF.EQ.0)CALL INPUT(INSUB) ! SET UP INPUT FUNCTION C C THROW AWAY ANY OLD STUFF 50 COL=RMARG+1 C C LOOK AT LINE C 100 I=SCAN() IF(I.EQ.0)GO TO 100 ! SPACES IF(I.EQ.2)GO TO 710 IF(I.EQ.4)GO TO 9900 ! EOF IF(INSTR(1).EQ."177)GO TO 720 ! JUST A CR IF(IGCOMF.NE.0)GO TO 120 ! SKIP THESE TWO ON SUBSEQUENT IF(INSTR(1).EQ.'?')GO TO 500 C IF(CKCOM('ME',2))GO TO 600 ! NO LONGER SUPPORTED 120 IF(CKCOM('DIRECTORY',2))GO TO 590 IF(CKCOM('DELETE',1))GO TO 800 IF(CKCOM('FILE',1))GO TO 900 IF(CKCOM('PRINT',1))GO TO 950 IF(CKCOM('SEND',1))GO TO 2000 IF(CKCOM('REPLY',1))GO TO 1000 IF(CKCOM('FORWARD',2))GO TO 1100 IF(CKCOM('READ',3))GO TO 700 IF(CKCOM('NEXT',1))GO TO 720 IF(CKCOM('BACK',1))GO TO 750 IF(CKCOM('CURRENT',1))GO TO 770 IF(CKCOM('EXIT',1))GO TO 9900 IF(CKCOM('QUIT',3))GO TO 9800 IF(CKCOM('HELP',1))GO TO 400 IF(CKCOM('UNDELETE',3))GO TO 850 IF(CKCOM('MCR',2))GO TO 8000 IF(CKCOM('DCL',2))GO TO 8100 300 WRITE(5,301) 301 FORMAT(' Syntax error. Type HELP if you need help.') GO TO 50 400 WRITE(5,401) 401 FORMAT(' MAIL accepts the following commands.'/' The required po', 1'rtion of each command is shown in UPPER CASE.',/ 1' Back Moves backward one message and types it.',/ 1' Current Types your current message again.') WRITE(5,403) 403 FORMAT( 1' DCl Execute specified DCL command.',/ 1' Delete Deletes the message you have just read.',/ 1' Optionally, the number of a message may be given.') WRITE(5,405) 405 FORMAT( 1' DIrectory Prints a directory of your mail.',/ 1' Optionally, "POSTOFFICE" or a file name may be given.') WRITE(5,410) 410 FORMAT( 1' Exit Exits from the mail program.',/ 1' File Files your message in the specified file.',/ 1' If no file is specified, MAIL.MAI will be used.',/ 1' FOrward Forwards the current message via SEND.',/ 1' Help Prints this text.') WRITE(5,420) 420 FORMAT( 1' MCr Execute specified MCR command.',/ 1' Next Moves to the next message and types it.',/ 1' Moves to the next message and types it.',/ 1' Print Prints the current message on the lineprinter.',/ 1' QUIt Exits without deleting any messages.') WRITE(5,430) 430 FORMAT( 1' REAd Moves to message n and types it.',/ 1' Moves to message n and types it.',/ 1' Reply Replies to the current message.',/ 1' Send Sends mail.') WRITE(5,435) 435 FORMAT( 1' UNDelete Restores the current message, if it was deleted.',/ 1' Optionally, the number of a message may be given.',/) WRITE(5,490) 490 FORMAT(' The following commands may also be used, but not after', 1' any other command.',/ 1' ? - To check for mail and specify [NO]NOTIFY.',/ 1,' ME - To read mail (old style).') GO TO 50 ! GO BACK AND GET A COMMAND 500 QMARK=.TRUE. QBRIE=.FALSE. READ=.FALSE. 501 I=SCAN() IF(I.EQ.0)GO TO 501 IF(I.EQ.3.AND.INSTR(1).EQ."177)RETURN IF(INSTR(1).NE.'/')GO TO 520 CALL SCAN IF(.NOT.CKCOM('BRIEF',2))GO TO 300 ! ONLY OPTION. STX ERR QBRIE=.TRUE. GO TO 501 520 IF(INSTR(1).NE.'N'.OR.INSTR(2).NE.'O'.OR.LINSTR.LT.3)RETURN IF(INSTR(3).EQ.'N'.OR.INSTR(3).EQ.'T')GO TO 525 RETURN 525 NOTCTL=1 NOTIFY=0 IF(INSTR(3).EQ.'T')NOTIFY=256 RETURN 590 IF(SCAN().EQ.0)GO TO 590 ICMDID=2 RETURN 600 MEMODE=.TRUE. RETURN C C READ, IN ITS VARIOUS FORMS C 700 I=SCAN() IF(I.EQ.0)GO TO 700 IF(I.EQ.2)GO TO 710 IF(INSTR(1).EQ."177)GO TO 720 GO TO 300 710 ICMDID=3 ! READ, WITH EXPLICIT NUMBER RETURN 720 ICMDID=4 ! READ NEXT (OR THE NEXT CMD) RETURN 750 ICMDID=5 ! BACK RETURN 770 ICMDID=15 ! CURRENT RETURN C C DELETE C 800 I=SCAN() IF(I.EQ.0)GO TO 800 IF(I.EQ.2)GO TO 810 IF(INSTR(1).EQ."177)GO TO 820 GO TO 300 810 ICMDID=12 ! DELETE WITH EXPLICIT NUMBER RETURN 820 ICMDID=6 ! DELETE CURRENT MESSAGE RETURN C C UNDELETE C 850 I=SCAN() IF(I.EQ.0)GO TO 850 IF(I.EQ.2)GO TO 860 IF(INSTR(1).EQ."177)GO TO 870 GO TO 300 860 ICMDID=14 ! UNDELETE WITH EXPLICIT NUMBER RETURN 870 ICMDID=13 ! UNDELETE CURRENT MESSAGE RETURN C 900 ICMDID=7 ! FILE RETURN 950 ICMDID=8 ! PRINT RETURN 1000 ICMDID=9 ! REPLY RETURN 1100 ICMDID=10 ! FORWARD RETURN 2000 CALL SENDCM GO TO 50 8000 CALL MCRCOM ! MCR GO TO 50 8100 CALL DCLCOM ! DCL GO TO 50 9800 IF(IGCOMF.EQ.0)CALL EXIT ICMDID=11 ! QUIT RETURN 9900 IF(IGCOMF.EQ.0)CALL EXIT ICMDID=1 RETURN END C C COMMAND TOKEN COMPARISON ROUTINE C LOGICAL FUNCTION CKCOM(CMD,MIN) C LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG C LOGICAL*1 CMD(31) CKCOM=.FALSE. IF(LINSTR.LT.MIN)RETURN ! NOT ENOUGH TO COMPARE DO 10 I=1,LINSTR 10 IF(INSTR(I).NE.CMD(I))RETURN ! DOES NOT COMPARE CKCOM=.TRUE. RETURN END C C INPUT SUBROUTINE FOR SCAN C FUNCTION INSUB(A) C LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG C LOGICAL*1 A(134) INTEGER IA(6) ! FOR WTQIO COMMON /IACOM/IA COMMON/INSUBC/IFIRST DATA IFIRST/0/ IF(IFIRST.NE.0)GO TO 50 IFIRST=IFIRST+1 CALL GETMCR(A,N) IF(N.GT.4)GO TO 100 ! MAY HAVE A COMMAND LINE 50 CALL GETADR(IA,IA(4)) ! A NULL IA(2)=1 ! ONLY ONE IA(3)="53 ! JUST A RETURN CALL WTQIO("440,5,1,,,IA) ! WRITE WITH CONTROL O CANCEL WRITE(5,51) 51 FORMAT(' MAIL>',$) READ(5,52,END=900)N,A IF(N.NE.0)CALL UPCASE(A,N) 52 FORMAT(Q,134A1) CALL WTQIO("440,5,1,,,IA) ! CCO, AGAIN, FOR GOOD MEASURE I=1 GO TO 200 100 DO 110 I=1,N IF(A(I).EQ.' ')GO TO 200 110 CONTINUE GO TO 50 ! NO SPACE ON LINE, PROMPT (MCR ONLY) 200 IF(I.GT.N)GO TO 300 ! ELIMINATE LEADING SPACES IF(A(I).NE.' ')GO TO 300 I=I+1 GO TO 200 300 COL=I N=N+1 A(N)="177 ! THE TERMINATOR SO MAIN CAN TELL EOL RMARG=N INSUB=1 RETURN 900 CALL WTQIO("440,5,1,,,IA) ! CCO, AGAIN, FOR GOOD MEASURE INSUB=0 RETURN END C C COUNT OF PRINTABLE DIGITS C FUNCTION LEN(I,IB) INTEGER*4 I4,J4 LEN=1 J=IB 100 IF(I.LT.J)RETURN J=J*IB LEN=LEN+1 GO TO 100 ENTRY LENS4(I4,IB) LENS4=1 J4=IB 200 IF(I4.LT.J4)RETURN J4=J4*IB LENS4=LENS4+1 GO TO 200 END C SUBROUTINE MOVE(A,B,N) C MOVE N CHARACTERS FROM A TO B LOGICAL*1 A(N),B(N) DO 100 I=1,N 100 B(I)=A(I) 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 OPNTMP(GLUN,A2,SVLUN,I) INTEGER GLUN(6) LOGICAL*1 A2(80) INTEGER SVLUN I=0 CALL GETLUN(5,GLUN) GLUN(2)=GLUN(2).AND."377 ENCODE(21,7001,A2)GLUN(1),GLUN(2),0 7001 FORMAT('LB:[1,7]',A2,O,'.TMP',A1) OPEN(UNIT=SVLUN,TYPE='NEW',NAME=A2 1,CARRIAGECONTROL='LIST',ERR=5) RETURN 5 I=I+1 RETURN END C C IMPLEMENT GTL SCAN FUNCTION FOR INPUT INTEGER FUNCTION SCAN() INTEGER SCANGD LOGICAL*1 A(134),CHAR,LA,LZ,AA,ZZ,BLNK,ZERO,NINE LOGICAL*1 INSTR,LINSTR,COL,LMARG,RMARG COMMON /SCANCM/INSTR(31),LINSTR,COL,LMARG,RMARG COMMON /SCANC2/IIJMP,ISUB COMMON /SCANIS/A DATA ISUB/0/,IIJMP/"137/ DATA AA,ZZ,BLNK,ZERO,NINE,LA,LZ/'A','Z',' ','0','9',97,122/ DATA LMARG/1/,RMARG/80/,COL/81/ IF(COL.LE.RMARG)GO TO 10 C WE HAD NO DATA PRESENT, SO READ IT IN COL=LMARG IF(ISUB.NE.0)GO TO 7 READ(5,5,END=999)A 5 FORMAT(80A1) GO TO 10 7 IF(SCANGD(IIJMP,A).EQ.0)GO TO 999 10 LINSTR=0 20 CHAR=A(COL) IF(CHAR.EQ.BLNK)GO TO 100 IF((CHAR.GE.AA.AND.CHAR.LE.ZZ).OR.(CHAR.GE.LA.AND.CHAR.LE.LZ)) 1 GO TO 200 IF(CHAR.GE.ZERO.AND.CHAR.LE.NINE)GO TO 300 C OTHERWISE, CHAR IS A SPECIAL CHAR, HANDLE HERE C IF THERE ARE ALREADY CHARACTERS IN INSTR, IT IS A TERMINATOR IF(LINSTR.NE.0)GO TO 900 C OTHERWISE WE RETURN IT ALONE SCAN=3 LINSTR=1 INSTR(1)=CHAR COL=COL+1 RETURN C HANDLE ALPHA CHARACTERS HERE 200 IF(LINSTR.EQ.0)GO TO 210 IF(SCAN.EQ.1)GO TO 800 C WE ARE EITHER BEGINNING OR CONTINUING ALPHA SCAN GO TO 900 C OTHERWISE WE TERMINATE AT 900 210 SCAN=1 GO TO 800 C HANDLE DIGITS HERE 300 IF(LINSTR.EQ.0)SCAN=2 IF(SCAN.EQ.0)GO TO 900 C IF WE HAD BEEN SCANNING SPACES, A DIGIT TERMINATES, BUT OTHERWISE C DIGITS MAY CONTINUE BOTH ALPHA AND DIGIT STRINGS GO TO 800 C HANDLE BLANKS HERE 100 IF(LINSTR.EQ.0)GO TO 110 IF(SCAN.EQ.0)GO TO 800 C IN THE ABOVE TWO CASES WE EITHER BEGAN OR CONTINUED TO SCAN SP C OTHERWISE THE SPACE IS A TERMINATOR... RETURN! GO TO 900 110 SCAN=0 GO TO 800 C INSERT THE CHARACTER JUST FOUND INTO INSTR 800 IF(LINSTR.EQ.31)GO TO 900 LINSTR=LINSTR+1 INSTR(LINSTR)=CHAR COL=COL+1 IF(COL.LE.RMARG)GO TO 20 C CONTINUE SCAN IF NOT YET DONE, OTHERWISE TERMINATE 900 RETURN 999 SCAN=4 RETURN END C INTEGER FUNCTION SCANGD(SUB,A) EXTERNAL SUB INTEGER SUB C THE USER'S INPUT FUNCTION RETURNS 0 ON END-OF-FILE, NON-ZERO OTHERWISE SCANGD=SUB(A) RETURN END C SUBROUTINE INPUT(SUB) INTEGER SUB COMMON/SCANC2/II,I C IF USER SAID CALL INPUT(0), WE RETURN TO STANDARD INPUT I=0 IF(SUB.NE.0)CALL GETADR(I,SUB) RETURN END C INTEGER FUNCTION INNUM(IBASE) LOGICAL*1 INSTR,LINSTR COMMON /SCANCM/INSTR(31),LINSTR INNUM=0 DO 10 I=1,LINSTR 10 INNUM=INNUM*IBASE + INSTR(I)-48 RETURN END