C C BULLETIN8.FOR, Version 10/27/94 C Purpose: Contains subroutines for the BULLETIN utility program. C Environment: VAX/VMS C Programmer: Mark R. London C SUBROUTINE START_DECNET IMPLICIT INTEGER (A - Z) COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN,MBX_CHAN1,DCL_CHAN1 COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for INTEGER*2 MBX_IOSB ! terminal QIO calls. LOGICAL*1 MBX_BUF PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /NEWSHOST/ NEWS_GOT_HOST COMMON /LISTEN/ LISTEN_CHAN,LISTEN_IOSB(4) INTEGER*2 LISTEN_IOSB CHARACTER NAMEDESC*12 /'BULLETIN1'/ CHARACTER NAMEDESC1*4 /'NNTP'/ DIMENSION NFBDESC(2) LOGICAL*1 NFB(5) EXTERNAL IO$_ACPCONTROL,LISTEN_AST PARAMETER NFB$C_DECLNAME = '15'X IF (CONFIRM_USER('DECNET').EQ.0) THEN CALL SETDEFAULT('DECNET') END IF C CALL SET_TIMER('02') GATEWAY_ONLY = SYS_TRNLNM('BULL_NEWS_GATEWAY_ONLY','DEFINED') NFBDESC(1) = 5 NFBDESC(2) = %LOC(NFB) NFB(1) = NFB$C_DECLNAME NEWS_GOT_HOST = NEWS_GETHOST() IF (.NOT.GATEWAY_ONLY) THEN IER = SYS$CREMBX(%VAL(0),MBX_CHAN,%VAL(132),%VAL(528),,, & 'BULL_MBX') IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT IER = SYS$ASSIGN('_NET:',DCL_CHAN,,'BULL_MBX') ! Assign net device IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT IER = SYS$QIOW(,%VAL(DCL_CHAN),IO$_ACPCONTROL,,,, & NFBDESC,NAMEDESC(:9),,,,) IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT CALL SYS$SETAST(%VAL(0)) CALL READ_MBX(DCL_CHAN) CALL SYS$SETAST(%VAL(1)) END IF IF (.NOT.SYS_TRNLNM('BULL_NO_NEWS_GATEWAY','DEFINED')) THEN IER = SYS$CREMBX(%VAL(0),MBX_CHAN1,%VAL(132),%VAL(528),,, & 'BULL_MBX1') IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT IER = SYS$ASSIGN('_NET:',DCL_CHAN1,,'BULL_MBX1') IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT IER = SYS$QIOW(,%VAL(DCL_CHAN1),IO$_ACPCONTROL,,,, & NFBDESC,NAMEDESC1,,,,) IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT CALL SYS$SETAST(%VAL(0)) CALL READ_MBX(DCL_CHAN1) CALL SYS$SETAST(%VAL(1)) END IF IF (SYS_TRNLNM('BULL_TCP_NEWS_GATEWAY','DEFINED')) THEN IF (NNTP_LISTEN(LISTEN_CHAN)) THEN CALL NNTP_ACCEPT_WAIT(LISTEN_CHAN,LISTEN_AST,LISTEN_IOSB) END IF END IF IF (GATEWAY_ONLY) CALL SYS$HIBER() RETURN END SUBROUTINE LISTEN_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /LISTEN/ LISTEN_CHAN,LISTEN_IOSB(4) INTEGER*2 LISTEN_IOSB COMMON /NNTP/ NNTP_CHANS(MAXLINK) COMMON /NEWSHOST/ NEWS_GOT_HOST EXTERNAL NEWS_SOCKET_AST INTEGER*2 ACCEPT_IOSB(4) IF (LISTEN_IOSB(1)) THEN IER = NNTP_ACCEPT(LISTEN_CHAN,ACCEPT_CHAN,ACCEPT_IOSB) IF (IER) THEN UNIT_INDEX = 1 DO WHILE (UNIT_INDEX.LE.MAXLINK.AND.UNITS(UNIT_INDEX).NE.0) UNIT_INDEX = UNIT_INDEX + 1 END DO IF (UNIT_INDEX.LE.MAXLINK) THEN COUNT = COUNT + 1 DEVS(UNIT_INDEX) = ACCEPT_CHAN UNITS(UNIT_INDEX) = ACCEPT_CHAN IER = NEWS_GOT_HOST.AND.NEWS_ASSIGN() IF (IER) THEN NNTP_CHANS(UNIT_INDEX) = NEWS_GET_CHAN() WRITE_IOSB(1,UNIT_INDEX) = 1 IER = NEWS_SOCKET_BULLCP(0, & WRITE_IOSB(1,UNIT_INDEX),NEWS_SOCKET_AST,UNIT_INDEX) IF (IER.EQ.-1) CALL NEWS_SOCKET_AST(%VAL(UNIT_INDEX)) END IF IF (.NOT.IER) CALL DISCONNECT(UNIT_INDEX) ELSE CALL SYS$DASSGN(%VAL(ACCEPT_CHAN)) END IF ELSE IF (ACCEPT_CHAN.NE.-1) THEN CALL SYS$DASSGN(%VAL(ACCEPT_CHAN)) END IF END IF CALL REQUEUE_NNTP_ACCEPT_WAIT() RETURN END SUBROUTINE REQUEUE_NNTP_ACCEPT_WAIT() IMPLICIT INTEGER (A-Z) COMMON /LISTEN/ LISTEN_CHAN,LISTEN_IOSB(4) INTEGER*2 LISTEN_IOSB EXTERNAL LISTEN_AST CALL NNTP_ACCEPT_WAIT(LISTEN_CHAN,LISTEN_AST,LISTEN_IOSB) RETURN END SUBROUTINE SETDEFAULT(USERNAME) IMPLICIT INTEGER (A-Z) INCLUDE '($LNMDEF)' INCLUDE '($PSLDEF)' INCLUDE '($UAIDEF)' CHARACTER DEFDIR*64,DEFDEV*16,USERNAME*(*),ACCOUNT*12 CHARACTER SYSLOGIN*72 INTEGER*2 UIC(2) CALL INIT_ITMLST CALL ADD_2_ITMLST(LEN(DEFDEV),UAI$_DEFDEV,%LOC(DEFDEV)) CALL ADD_2_ITMLST(LEN(DEFDIR),UAI$_DEFDIR,%LOC(DEFDIR)) CALL ADD_2_ITMLST(LEN(ACCOUNT),UAI$_ACCOUNT,%LOC(ACCOUNT)) CALL ADD_2_ITMLST(4,UAI$_UIC,%LOC(UIC)) CALL END_ITMLST(GETUAI_ITMLST) CALL SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) CALL SETACC(ACCOUNT) CALL SETUSER(USERNAME) CALL SETUIC(INT(UIC(2)),INT(UIC(1))) CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST & (ICHAR(DEFDEV(:1)),LNM$_STRING,%LOC(DEFDEV(2:))) CALL END_ITMLST(CRELNM_ITMLST) ! Get address of itemlist CALL SYS$CRELNM(,'LNM$PROCESS','SYS$DISK',PSL$C_SUPER, & %VAL(CRELNM_ITMLST)) CALL INIT_ITMLST ! Initialize item list ! Now add items to list SYSLOGIN = 'SYS$DISK:'//DEFDIR(2:) CALL ADD_2_ITMLST & (ICHAR(DEFDIR(:1))+9,LNM$_STRING,%LOC(SYSLOGIN)) CALL END_ITMLST(CRELNM_ITMLST) ! Get address of itemlist CALL SYS$CRELNM(,'LNM$PROCESS','SYS$LOGIN',PSL$C_SUPER, & %VAL(CRELNM_ITMLST)) CALL SYS$SETDDIR(DEFDIR(2:ICHAR(DEFDIR(:1))+1),,) RETURN END SUBROUTINE READ_MBX(DCL_CHAN_NUM) IMPLICIT INTEGER (A-Z) COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN,MBX_CHAN1,DCL_CHAN1 COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for INTEGER*2 MBX_IOSB ! terminal QIO calls. LOGICAL*1 MBX_BUF EXTERNAL MBX_AST EXTERNAL IO$_READVBLK DATA MBX_EF/0/ IF (MBX_EF.EQ.0) CALL LIB$GET_EF(MBX_EF) IF (DCL_CHAN_NUM.EQ.DCL_CHAN) THEN MBX_CHAN_NUM = MBX_CHAN ELSE MBX_CHAN_NUM = MBX_CHAN1 END IF IER = SYS$QIO(%VAL(MBX_EF),%VAL(MBX_CHAN_NUM), & IO$_READVBLK,MBX_IOSB, & MBX_AST,%VAL(DCL_CHAN_NUM),MBX_BUF,%VAL(132),,,,) IF (.NOT.IER) CALL SYS_GETMSG(IER) IF (.NOT.IER) CALL EXIT RETURN END SUBROUTINE MBX_AST(DCL_CHAN_NUM) IMPLICIT INTEGER (A-Z) INCLUDE '($MSGDEF)' INCLUDE 'BULLUSER.INC' PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for INTEGER*2 MBX_IOSB ! terminal QIO calls. LOGICAL*1 MBX_BUF INTEGER*2 MBXMSG,UNIT2 EQUIVALENCE (MBX_BUF(1),MBXMSG) CHARACTER NODENAME*8,FROMNAME*12 IF (MBXMSG.EQ.MSG$_CONNECT.AND.MBX_IOSB(1)) THEN LNODE = 0 DO WHILE (MBX_BUF(10+LNODE).NE.':') LNODE = LNODE + 1 NODENAME(LNODE:LNODE) = CHAR(MBX_BUF(9+LNODE)) END DO DO I=LNODE+1,LEN(NODENAME) NODENAME(I:I) = ' ' END DO I = 10 + LNODE DO WHILE (MBX_BUF(I).NE.'=') I = I + 1 END DO LUSER = 0 DO WHILE (MBX_BUF(I+LUSER+1).NE.' '.AND. & MBX_BUF(I+LUSER+1).NE.'/') LUSER = LUSER + 1 USERNAME(LUSER:LUSER) = CHAR(MBX_BUF(I+LUSER)) END DO DO I=LUSER+1,LEN(USERNAME) USERNAME(I:I) = ' ' END DO FROMNAME = USERNAME CALL GET_PROXY_USERNAME(NODENAME,USERNAME) CALL BULL_CONNECT(NODENAME,USERNAME,FROMNAME,%LOC(DCL_CHAN_NUM)) ELSE IF ((MBXMSG.EQ.MSG$_INTMSG.OR.MBXMSG.EQ.MSG$_REJECT.OR. & MBXMSG.EQ.MSG$_CONFIRM).AND.MBX_IOSB(1)) THEN CALL READ_MBX(%LOC(DCL_CHAN_NUM)) ELSE CALL LIB$MOVC3(2,MBX_BUF(3),UNIT2) UNIT_INDEX = 1 DO WHILE (UNIT_INDEX.LE.MAXLINK.AND.UNITS(UNIT_INDEX).NE.UNIT2) UNIT_INDEX = UNIT_INDEX + 1 END DO IF (UNIT_INDEX.LE.MAXLINK) CALL DISCONNECT(UNIT_INDEX) CALL READ_MBX(%LOC(DCL_CHAN_NUM)) END IF RETURN END SUBROUTINE READ_CHAN(CHAN,UNIT_INDEX) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF EXTERNAL READ_AST EXTERNAL IO$_READVBLK IER = SYS$QIO(,%VAL(CHAN),IO$_READVBLK, & READ_IOSB(1,UNIT_INDEX),READ_AST, & %VAL(UNIT_INDEX),READ_BUF(1,UNIT_INDEX),%VAL(1024),,,,) RETURN END SUBROUTINE WRITE_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDERNAME(MAXLINK) COMMON /CONNECT_STATUS/ FROM_SAVE(MAXLINK),PRIV_SAVE(2,MAXLINK) COMMON /CONNECT_STATUS/ NODE_SAVE(MAXLINK),OUT_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ REC_SAVE(MAXLINK),LEN_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ LAST_SAVE(2,MAXLINK),LAST_SYS_SAVE(2,MAXLINK) CHARACTER USER_SAVE*12,FOLDERNAME*44,FROM_SAVE*12,NODE_SAVE*12 COMMON /NNTP/ NNTP_CHANS(MAXLINK) CHARACTER*128 INPUT EXTERNAL IO$_READVBLK,NEWS_READ_AST UNIT_INDEX = %LOC(ASTPRM) IF (.NOT.WRITE_IOSB(1,UNIT_INDEX)) THEN CALL DISCONNECT(UNIT_INDEX) ELSE IF (LEN_SAVE(UNIT_INDEX).GT.0) THEN LEN_SAVE(UNIT_INDEX) = LEN_SAVE(UNIT_INDEX) - 1 IF (LEN_SAVE(UNIT_INDEX).EQ.0) THEN IF (REC_SAVE(UNIT_INDEX).EQ.128) THEN REC_SAVE(UNIT_INDEX) = 0 ELSE RETURN END IF ELSE CALL READ_QUEUE(%VAL(OUT_SAVE(UNIT_INDEX)), & OUT_SAVE(UNIT_INDEX),INPUT) END IF CALL WRITE_CHAN(REC_SAVE(UNIT_INDEX),INPUT,UNIT_INDEX,IER) ELSE IF (NNTP_CHANS(UNIT_INDEX).NE.0) THEN IER = SYS$QIO(,%VAL(NNTP_CHANS(UNIT_INDEX)), & IO$_READVBLK,WRITE_IOSB(1,UNIT_INDEX),NEWS_READ_AST, & %VAL(UNIT_INDEX),WRITE_BUF(1,UNIT_INDEX), & %VAL(1024),,,,) IF (IER.AND.WRITE_IOSB(1,UNIT_INDEX).NE.0) THEN IER = WRITE_IOSB(1,UNIT_INDEX) END IF IF (.NOT.IER) CALL DISCONNECT(UNIT_INDEX) END IF RETURN END SUBROUTINE READ_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) COMMON /NNTP/ NNTP_CHANS(MAXLINK) EXTERNAL NEWS_WRITE_AST EXTERNAL IO$_WRITEVBLK UNIT_INDEX = %LOC(ASTPRM) IF (.NOT.READ_IOSB(1,UNIT_INDEX)) RETURN C IO(UNIT_INDEX) = IO(UNIT_INDEX) + 1 CALL LIB$MOVC3(4,READ_BUF(1,UNIT_INDEX),CMD_TYPE) IF ((CMD_TYPE.LT.1.OR.CMD_TYPE.GT.16).AND. & READ_IOSB(2,UNIT_INDEX).EQ.0) THEN CALL DISCONNECT(UNIT_INDEX) ELSE IF (CMD_TYPE.LT.1.OR.CMD_TYPE.GT.16) THEN CALL NEWS_SET_CHAN(NNTP_CHANS(UNIT_INDEX)) IER = NEWS_WRITE_PACKET_BULLCP(0, & READ_IOSB(1,UNIT_INDEX),NEWS_WRITE_AST,UNIT_INDEX, & READ_BUF(1,UNIT_INDEX),READ_IOSB(2,UNIT_INDEX)) IF (IER.AND.READ_IOSB(1,UNIT_INDEX).NE.0) THEN IER = READ_IOSB(1,UNIT_INDEX) END IF IF (.NOT.IER) CALL DISCONNECT(UNIT_INDEX) ELSE CALL EXECUTE_COMMAND(UNIT_INDEX) CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) END IF RETURN END SUBROUTINE NEWS_WRITE_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /NNTP/ NNTP_CHANS(MAXLINK) UNIT_INDEX = %LOC(ASTPRM) IF (READ_IOSB(1,UNIT_INDEX)) THEN CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) RETURN END IF CALL DISCONNECT(UNIT_INDEX) RETURN END SUBROUTINE NEWS_READ_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF UNIT_INDEX = %LOC(ASTPRM) IF (WRITE_IOSB(1,UNIT_INDEX)) THEN NUM = WRITE_IOSB(2,UNIT_INDEX) CALL WRITE_CHAN_BUF(NUM,UNIT_INDEX,IER) IF (IER) RETURN END IF CALL DISCONNECT(UNIT_INDEX) RETURN END SUBROUTINE WRITE_CHAN(NUM,OUTPUT,UNIT_INDEX,IER) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF CHARACTER*(*) OUTPUT EXTERNAL IO$_WRITEVBLK, WRITE_AST CALL LIB$MOVC3(NUM,%REF(OUTPUT),WRITE_BUF(1,UNIT_INDEX)) ENTRY WRITE_CHAN_BUF(NUM,UNIT_INDEX,IER) IER = SYS$QIO(,%VAL(DEVS(UNIT_INDEX)), & IO$_WRITEVBLK,WRITE_IOSB(1,UNIT_INDEX),WRITE_AST, & %VAL(UNIT_INDEX),WRITE_BUF(1,UNIT_INDEX),%VAL(NUM),,,,) IF (IER.AND.WRITE_IOSB(1,UNIT_INDEX).NE.0) THEN IER = WRITE_IOSB(1,UNIT_INDEX) END IF RETURN END SUBROUTINE BULL_CONNECT(NODENAME,USERNAME,FROMNAME,DCL_CHAN_NUM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN,MBX_CHAN1,DCL_CHAN1 COMMON /NNTP/ NNTP_CHANS(MAXLINK) CHARACTER*(*) USERNAME,FROMNAME COMMON /NEWSHOST/ NEWS_GOT_HOST EXTERNAL IO$_ACCESS,IO$M_ABORT,NEWS_SOCKET_AST IO_REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) CALL CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, & NODENAME,USERNAME,FROMNAME,DCL_CHAN_NUM) IF (REJECT.NE.IO_REJECT) THEN IF (DCL_CHAN_NUM.NE.DCL_CHAN) THEN IER = NEWS_GOT_HOST.AND.NEWS_ASSIGN() IF (IER) THEN NNTP_CHANS(UNIT_INDEX) = NEWS_GET_CHAN() WRITE_IOSB(1,UNIT_INDEX) = 1 IER = NEWS_SOCKET_BULLCP(0, & WRITE_IOSB(1,UNIT_INDEX),NEWS_SOCKET_AST,UNIT_INDEX) IF (IER.EQ.-1) CALL NEWS_SOCKET_AST(%VAL(UNIT_INDEX)) END IF IF (.NOT.IER) CALL DISCONNECT(UNIT_INDEX) ELSE CALL READ_CHAN(CHAN,UNIT_INDEX) END IF END IF CALL READ_MBX(DCL_CHAN_NUM) RETURN END SUBROUTINE NEWS_SOCKET_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /NNTP/ NNTP_CHANS(MAXLINK) EXTERNAL NEWS_CREATE_AST UNIT_INDEX = %LOC(ASTPRM) IF (WRITE_IOSB(1,UNIT_INDEX)) THEN CALL NEWS_SET_CHAN(NNTP_CHANS(UNIT_INDEX)) IER = NEWS_CREATE_BULLCP(0, & WRITE_IOSB(1,UNIT_INDEX),NEWS_CREATE_AST,UNIT_INDEX) IF (IER) RETURN END IF CALL DISCONNECT(UNIT_INDEX) RETURN END SUBROUTINE NEWS_CREATE_AST(ASTPRM) IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF UNIT_INDEX = %LOC(ASTPRM) IF (WRITE_IOSB(1,UNIT_INDEX)) THEN CALL WRITE_AST(%VAL(UNIT_INDEX)) CALL READ_CHAN(DEVS(UNIT_INDEX),UNIT_INDEX) ELSE CALL DISCONNECT(UNIT_INDEX) END IF RETURN END SUBROUTINE CONNECT_ACCEPT(REJECT,CHAN,UNIT_INDEX, & NODENAME,USERNAME,FROMNAME,DCL_CHAN_NUM) IMPLICIT INTEGER (A-Z) COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for INTEGER*2 MBX_IOSB ! terminal QIO calls. LOGICAL*1 MBX_BUF PARAMETER MAXLINK = 20 COMMON /PROCBUF/ WRITE_IOSB(4,MAXLINK),WRITE_BUF(1024,MAXLINK) INTEGER*2 WRITE_IOSB LOGICAL*1 WRITE_BUF COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF DATA COUNT /0/ COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDERNAME(MAXLINK) COMMON /CONNECT_STATUS/ FROM_SAVE(MAXLINK),PRIV_SAVE(2,MAXLINK) COMMON /CONNECT_STATUS/ NODE_SAVE(MAXLINK),OUT_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ REC_SAVE(MAXLINK),LEN_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ LAST_SAVE(2,MAXLINK),LAST_SYS_SAVE(2,MAXLINK) CHARACTER USER_SAVE*12,FOLDERNAME*44,FROM_SAVE*12,NODE_SAVE*12 COMMON /CHANNEL/ MBX_CHAN,DCL_CHAN,MBX_CHAN1,DCL_CHAN1 EXTERNAL IO$_ACCESS,IO$M_ABORT CHARACTER*(*) USERNAME,FROMNAME,NODENAME CHARACTER*100 NCBDESC START_NCB = 7+MBX_BUF(5) LEN_NCB = MBX_BUF(START_NCB-1) CALL LIB$MOVC3(LEN_NCB,MBX_BUF(START_NCB),%REF(NCBDESC)) IF (COUNT.GT.MAXLINK) THEN REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) CHAN = DCL_CHAN_NUM ELSE IF (DCL_CHAN_NUM.EQ.DCL_CHAN) THEN IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX') ELSE IER = SYS$ASSIGN('_NET:',DEV_CHAN,,'BULL_MBX1') END IF IF (IER) CALL GETDEVUNIT(DEV_CHAN,DEV_UNIT,IER) IF (IER) THEN CHAN = DEV_CHAN REJECT = %LOC(IO$_ACCESS) UNIT_INDEX = 1 DO WHILE (UNIT_INDEX.LE.MAXLINK.AND.UNITS(UNIT_INDEX).NE.0) UNIT_INDEX = UNIT_INDEX + 1 END DO ELSE CALL SYS$DASSGN(%VAL(DEV_CHAN)) END IF IF (.NOT.IER.OR.UNIT_INDEX.GT.MAXLINK) THEN REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) CHAN = DCL_CHAN_NUM ELSE COUNT = COUNT + 1 UNITS(UNIT_INDEX) = DEV_UNIT DEVS(UNIT_INDEX) = DEV_CHAN USER_SAVE(UNIT_INDEX) = USERNAME FROM_SAVE(UNIT_INDEX) = FROMNAME NODE_SAVE(UNIT_INDEX) = NODENAME FOLDER_NUM(UNIT_INDEX) = -1 LEN_SAVE(UNIT_INDEX) = 0 PRIV_SAVE(1,UNIT_INDEX) = 0 PRIV_SAVE(2,UNIT_INDEX) = 0 END IF END IF IER = SYS$QIOW(,%VAL(CHAN),%VAL(REJECT),MBX_IOSB,,, & ,NCBDESC(:LEN_NCB),,,,) IF (REJECT.EQ.%LOC(IO$_ACCESS).AND. & (.NOT.IER.OR..NOT.MBX_IOSB(1))) THEN REJECT = %LOC(IO$_ACCESS)+%LOC(IO$M_ABORT) COUNT = COUNT - 1 DEVS(UNIT_INDEX) = 0 UNITS(UNIT_INDEX) = 0 END IF RETURN END SUBROUTINE GETDEVUNIT(CHAN,DEV_UNIT,IER) C C SUBROUTINE GETDEVUNIT C C FUNCTION: C To get device unit number C INPUT: C CHAN - Channel number C OUTPUT: C DEV_UNIT - Device unit number C IMPLICIT INTEGER (A-Z) INCLUDE '($DVIDEF)' CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST(4,DVI$_UNIT,%LOC(DEV_UNIT)) CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist IER = SYS$GETDVIW(,%VAL(CHAN),,%VAL(GETDVI_ITMLST),,,,) RETURN END SUBROUTINE GETDEVNAME(CHAN,DEV_NAME,DLEN,IER) C C SUBROUTINE GETDEVMAME C C FUNCTION: C To get device name C INPUT: C CHAN - Channel number C OUTPUT: C DEV_NAME - Device name C DLEN - Length of device name C IMPLICIT INTEGER (A-Z) INCLUDE '($DVIDEF)' CHARACTER*(*) DEV_NAME CALL INIT_ITMLST ! Initialize item list ! Now add items to list CALL ADD_2_ITMLST_WITH_RET & (LEN(DEV_NAME),DVI$_DEVNAM,%LOC(DEV_NAME),%LOC(DLEN)) CALL END_ITMLST(GETDVI_ITMLST) ! Get address of itemlist IER = SYS$GETDVIW(,%VAL(CHAN),,%VAL(GETDVI_ITMLST),,,,) RETURN END SUBROUTINE DISCONNECT(UNIT_INDEX) C C SUBROUTINE DISCONNECT C C FUNCTION: Disconnects channel and remove its entry from the lists. C IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /MBXBUF/ MBX_IOSB(4),MBX_BUF(132) ! Buffer area for INTEGER*2 MBX_IOSB ! terminal QIO calls. LOGICAL*1 MBX_BUF COMMON /NNTP/ NNTP_CHANS(MAXLINK) IF (UNITS(UNIT_INDEX).EQ.0) RETURN CALL SYS$DASSGN(%VAL(DEVS(UNIT_INDEX))) IF (NNTP_CHANS(UNIT_INDEX).EQ.0) THEN CALL UPDATE_REMOTE_USERINFO(UNIT_INDEX) END IF COUNT = COUNT - 1 DEVS(UNIT_INDEX) = 0 UNITS(UNIT_INDEX) = 0 IF (NNTP_CHANS(UNIT_INDEX).NE.0) THEN CALL NEWS_SET_CHAN(NNTP_CHANS(UNIT_INDEX)) CALL NEWS_DISCONNECT NNTP_CHANS(UNIT_INDEX) = 0 END IF RETURN END SUBROUTINE SET_TIMER(MIN) C C SUBROUTINE SET_TIMER C C FUNCTION: Wakes up every MIN minutes to check for idle connections C IMPLICIT INTEGER (A-Z) INTEGER TIMADR(2) ! Buffer containing time ! in desired system format. CHARACTER MIN*(*) EXTERNAL CHECK_CONNECTIONS CALL LIB$GET_EF(WAITEFN) IER=SYS$BINTIM('0 00:'//MIN//':00.00',TIMADR) ENTRY RESET_TIMER IER=SYS$SETIMR(%VAL(WAITEFN),TIMADR,CHECK_CONNECTIONS,) ! Set timer. RETURN END SUBROUTINE CHECK_CONNECTIONS IMPLICIT INTEGER (A-Z) PARAMETER MAXLINK = 20 COMMON /ACTIVITY/ IO(MAXLINK),IO_SAVE(MAXLINK) COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF IF (COUNT.GT.0) THEN DO UNIT_INDEX=1,MAXLINK IF (DEVS(UNIT_INDEX).NE.0.AND. & IO(UNIT_INDEX).EQ.IO_SAVE(UNIT_INDEX)) THEN CALL DISCONNECT(UNIT_INDEX) END IF END DO END IF CALL RESET_TIMER RETURN END SUBROUTINE GET_USER_PRIV(USERNAME,PRIV) IMPLICIT INTEGER (A-Z) DIMENSION PRIV(2) CHARACTER USERNAME*(*) INCLUDE '($UAIDEF)' INTEGER*2 UIC(2) CALL INIT_ITMLST CALL ADD_2_ITMLST(8,UAI$_PRIV,%LOC(PRIV)) CALL END_ITMLST(GETUAI_ITMLST) IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) IF (.NOT.IER) THEN USERNAME = 'DECNET' IER = SYS$GETUAI(,,USERNAME,%VAL(GETUAI_ITMLST),,,) END IF RETURN END SUBROUTINE GET_PROXY_USERNAME(NODE,USERNAME) IMPLICIT INTEGER (A-Z) CHARACTER NODE*(*),USERNAME*(*) CHARACTER NETUAF*100,USERTEMP*12 COMMON /NETUAF/ NETUAF_QUEUE,NETUAF_NUM LNODE = LEN(NODE) LUSER = LEN(USERNAME) NUM = 1 NENTRY = NETUAF_QUEUE USERTEMP = 'DECNET' DO WHILE (NUM.LE.NETUAF_NUM) NUM = NUM + 1 CALL READ_QUEUE(%VAL(NENTRY),NENTRY,NETUAF) IF ((NETUAF(:1).EQ.'*'.OR.NETUAF(:LNODE).EQ.NODE).AND. & (NETUAF(33:32+LUSER).EQ.USERNAME.OR. & NETUAF(65:65).EQ.'*')) THEN IF (NETUAF(33:32+LUSER).EQ.USERNAME) THEN IF (NETUAF(65:65).NE.'*') USERNAME = NETUAF(65:) RETURN END IF IF (NETUAF(65:65).NE.'*') THEN USERTEMP = NETUAF(65:) ELSE USERTEMP = USERNAME END IF END IF END DO USERNAME = USERTEMP RETURN END SUBROUTINE GET_PROXY_ACCOUNTS IMPLICIT INTEGER (A-Z) CHARACTER NETUAF*656 COMMON /NETUAF/ NETUAF_QUEUE,NETUAF_NUM DATA NETUAF_QUEUE/0/ CALL INIT_QUEUE(NETUAF_QUEUE,NETUAF(:100)) OPEN (UNIT=7,FILE='NETPROXY',DEFAULTFILE='SYS$SYSTEM:NETPROXY.DAT', & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) FORMAT = 0 IF (IER.NE.0) THEN OPEN (UNIT=7,FILE='NETUAF',DEFAULTFILE='SYS$SYSTEM:NETUAF.DAT', & ACCESS='KEYED',FORM='FORMATTED',ORGANIZATION='INDEXED', & STATUS='OLD',READONLY,SHARED,IOSTAT=IER) FORMAT = 1 END IF NETUAF_NUM = 0 NENTRY = NETUAF_QUEUE DO WHILE (IER.EQ.0) READ (7,'(Q,A)',IOSTAT=IER) NLEN,NETUAF IF (IER.EQ.0) THEN NETUAF_NUM = NETUAF_NUM + 1 IF (FORMAT.EQ.0) THEN NETUAF = NETUAF(13:) NLEN = NLEN - 12 DO WHILE (NETUAF(67:67).NE.CHAR(1).AND.NLEN.GT.64) SKIP = 4 + ICHAR(NETUAF(65:65)) NETUAF(65:) = NETUAF(65+SKIP:) NLEN = NLEN - SKIP END DO IF (NLEN.GT.64) THEN ULEN = ICHAR(NETUAF(65:65)) NETUAF(65:) = NETUAF(69:) DO I=65+ULEN,76 NETUAF(I:I) = ' ' END DO ELSE NETUAF(65:) = 'DECNET' END IF END IF CALL WRITE_QUEUE(%VAL(NENTRY),NENTRY,NETUAF(:100)) END IF END DO CLOSE (UNIT=7) RETURN END SUBROUTINE EXECUTE_COMMAND(UNIT_INDEX) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLUSER.INC' INCLUDE 'BULLFILES.INC' PARAMETER MAXLINK = 20 COMMON /READBUF/ READ_IOSB(4,MAXLINK),READ_BUF(1024,MAXLINK) COMMON /READBUF/ DEVS(MAXLINK),UNITS(MAXLINK),COUNT INTEGER*2 READ_IOSB LOGICAL*1 READ_BUF COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDERNAME(MAXLINK) COMMON /CONNECT_STATUS/ FROM_SAVE(MAXLINK),PRIV_SAVE(2,MAXLINK) COMMON /CONNECT_STATUS/ NODE_SAVE(MAXLINK),OUT_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ REC_SAVE(MAXLINK),LEN_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ LAST_SAVE(2,MAXLINK),LAST_SYS_SAVE(2,MAXLINK) CHARACTER USER_SAVE*12,FOLDERNAME*44,FROM_SAVE*12,NODE_SAVE*12 COMMON /ACCESS/ READ_ONLY LOGICAL READ_ONLY COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) COMMON /POINT/ BULL_POINT COMMON /REMOTE_FOLDER/ REMOTE_SET,REMOTE_UNIT COMMON /BROAD_MESSAGE/ BMESSAGE,BLENGTH PARAMETER BRDCST_LIMIT = 82*12 + 2 +2 CHARACTER*(BRDCST_LIMIT) BMESSAGE COMMON /MAIN_FOLDER_DIRECTORY/ FOLDER1_DIRECTORY CHARACTER*80 FOLDER1_DIRECTORY CHARACTER*80 FOLDER2_DIRECTORY DIMENSION SCRATCH(MAXLINK),OUT_HEAD(MAXLINK) DATA SCRATCH/MAXLINK*0/,OUT_HEAD/MAXLINK*0/ EXTERNAL SS$_NOSUCHNODE,SS$_NOSUCHOBJ CHARACTER BUFFER*(FOLDER_RECORD+16),DESCRIP_TEMP*56 CHARACTER NODENAME*8,BULLCP_USER*12,INQUEUE*128 EQUIVALENCE (BUFFER,CMD_TYPE),(BUFFER,INQUEUE) INTEGER BULLCP_PRIV(2) CALL COPY2(BULLCP_PRIV,PROCPRIV) ILEN = READ_IOSB(2,UNIT_INDEX) CALL LIB$MOVC3(ILEN,READ_BUF(1,UNIT_INDEX),%REF(BUFFER)) REMOTE_SET = .FALSE. REC_SAVE(UNIT_INDEX) = 0 USERNAME = USER_SAVE(UNIT_INDEX) FOLDER = FOLDERNAME(UNIT_INDEX) FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) FOLDER_FLAG = 0 NODENAME = NODE_SAVE(UNIT_INDEX) CALL COPY2(PROCPRIV,PRIV_SAVE(1,UNIT_INDEX)) CALL INIT_QUEUE(OUT_HEAD(UNIT_INDEX),INQUEUE) IF (CMD_TYPE.EQ.3.OR.CMD_TYPE.EQ.4.OR.(CMD_TYPE.GE.9.AND. & CMD_TYPE.LE.11).OR.CMD_TYPE.EQ.15.OR.CMD_TYPE.EQ.1) THEN ! Do we need priv info? IF (PROCPRIV(1).EQ.0.AND.PROCPRIV(2).EQ.0) THEN CALL GET_USER_PRIV(USER_SAVE(UNIT_INDEX), & PRIV_SAVE(1,UNIT_INDEX)) USERNAME = USER_SAVE(UNIT_INDEX) ! If changed to DECNET CALL COPY2(PROCPRIV,PRIV_SAVE(1,UNIT_INDEX)) IF ( (PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN CALL CHECK_BULLETIN_PRIV(USERNAME) CALL COPY2(PRIV_SAVE(1,UNIT_INDEX),PROCPRIV) END IF END IF END IF FOLDER2_DIRECTORY = FOLDER_DIRECTORY IF (FOLDER_DIRECTORY.NE.FOLDER1_DIRECTORY.AND. & TRIM(FOLDER1_DIRECTORY).GT.0) THEN FOLDER_DIRECTORY = FOLDER1_DIRECTORY CALL ADD_DIRECTORIES END IF IF (CMD_TYPE.EQ.1.AND.BUFFER(ILEN:ILEN).EQ.'?') THEN IF (BUFFER(5:ILEN).EQ.'SYSTEM?') THEN CALL LIB$MOVC3(4,1,%REF(BUFFER(1:))) CALL WRITE_CHAN(4,BUFFER,UNIT_INDEX,IER1) ELSE CALL LIB$MOVC3(4,0,%REF(BUFFER(1:))) CALL WRITE_CHAN(4,BUFFER,UNIT_INDEX,IER1) END IF ELSE IF (CMD_TYPE.EQ.1) THEN ! Select folder IF (BUFFER(ILEN:ILEN).EQ.'+') THEN SYSLOG = .TRUE. ILEN = ILEN - 1 ELSE SYSLOG = .FALSE. END IF FOLDER1 = BUFFER(5:ILEN) FOLDER_NUMBER = -2 CALL SELECT_FOLDER(.FALSE.,IER) CALL LIB$MOVC3(4,IER,%REF(BUFFER(1:))) CALL LIB$MOVC3(4,READ_ONLY,%REF(BUFFER(5:))) IF (USERNAME.NE.'DECNET'.AND.IER) THEN CALL OPEN_USERINFO IF (USERNAME.EQ.'DECNET') THEN ! User wasn't real. USER_SAVE(UNIT_INDEX) = USERNAME CALL LIB$MOVC3(4,0,%REF(BUFFER(9:))) CALL LIB$MOVC3(4,0,%REF(BUFFER(13:))) ELSE CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), & %REF(BUFFER(9:))) LAST_SAVE(1,UNIT_INDEX) = LAST_READ_BTIM(1,FOLDER_NUMBER+1) LAST_SAVE(2,UNIT_INDEX) = LAST_READ_BTIM(2,FOLDER_NUMBER+1) END IF ELSE CALL LIB$MOVC3(4,0,%REF(BUFFER(9:))) CALL LIB$MOVC3(4,0,%REF(BUFFER(13:))) END IF LINFO = 16 IF (SYSLOG) THEN LINFO = 24 CALL LIB$MOVC3(8,LAST_SYS_BTIM(1,FOLDER_NUMBER+1), & LAST_SYS_SAVE(1,UNIT_INDEX)) CALL LIB$MOVC3(8,LAST_SYS_BTIM(1,FOLDER_NUMBER+1), & %REF(BUFFER(17:))) IF (LAST_SYS_SAVE(1,UNIT_INDEX).EQ.0) THEN CALL LIB$MOVC3(8,LAST_READ_BTIM(1,FOLDER_NUMBER+1), & LAST_SYS_BTIM(1,FOLDER_NUMBER+1)) END IF END IF BUFFER = BUFFER(:LINFO)//FOLDER_COM CALL WRITE_CHAN(LINFO+LEN(FOLDER_COM),BUFFER,UNIT_INDEX,IER1) IF (IER.AND.IER1) THEN IF (SYSLOG) THEN CALL SAVE_LAST_SYS_BTIM(UNIT_INDEX) ELSE LAST_SYS_SAVE(1,UNIT_INDEX) = 0 LAST_SYS_SAVE(2,UNIT_INDEX) = 0 END IF FOLDERNAME(UNIT_INDEX) = FOLDER FOLDER_NUM(UNIT_INDEX) = FOLDER_NUMBER END IF ELSE IF (CMD_TYPE.EQ.2) THEN ! Add message LEN_SAVE(UNIT_INDEX) = 0 OUT_SAVE(UNIT_INDEX) = OUT_HEAD(UNIT_INDEX) ELSE IF (CMD_TYPE.EQ.6) THEN ! Add message line LEN_SAVE(UNIT_INDEX) = LEN_SAVE(UNIT_INDEX) + 1 CALL WRITE_QUEUE(%VAL(OUT_SAVE(UNIT_INDEX)), & OUT_SAVE(UNIT_INDEX),BUFFER(5:132)) ELSE IF (CMD_TYPE.EQ.3) THEN ! Add message entry FROM = USER_SAVE(UNIT_INDEX) IF (FROM.EQ.'DECNET') FROM = FROM_SAVE(UNIT_INDEX) CALL LIB$MOVC3(56,%REF(BUFFER(5:)),%REF(DESCRIP)) P = LEN(DESCRIP) + 5 CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXDATE)) P = LEN(EXDATE) + P CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXTIME)) P = LEN(EXTIME) + P CALL LIB$MOVC3(4,%REF(BUFFER(P:)),SYSTEM) P = 4 + P FOLDER1 = FOLDER FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) IF (READ_ONLY.AND. & FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN BUFFER = 'ERROR: Insufficient privileges to add message.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 ELSE IF ((SYSTEM.AND.7).NE.0) THEN IF (FOLDER_NUMBER.GT.0.AND.IBCLR(SYSTEM,1).NE.0.AND. & .NOT.BTEST(FOLDER_FLAG,2)) THEN ! Test if SYSTEM folder SYSTEM = SYSTEM.AND.2 CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) END IF IF ((SYSTEM.AND.7).NE.0.AND..NOT.SETPRV_PRIV()) THEN ! Priv test IF (F_EXPIRE_LIMIT.GT.0.AND..NOT. ! Expiration limit present & FOLDER_ACCESS(USERNAME,FOLDER_FLAG,FOLDER_OWNER)) THEN SYSTEM = 0 CALL GET_EXDATE(EXDATE,FOLDER_BBEXPIRE) ELSE ! Allow permanent if SYSTEM = SYSTEM.AND.2 ! owner of folder END IF END IF IF (BTEST(SYSTEM,2)) THEN ! Shutdown? CALL GET_NODE_NUMBER(NODE_NUMBER,NODE_AREA) WRITE (EXTIME,'(I4)') NODE_NUMBER WRITE (EXTIME(7:),'(I4)') NODE_AREA DO I=1,11 IF (EXTIME(I:I).EQ.' ') EXTIME(I:I) = '0' END DO EXTIME = EXTIME(1:2)//':'//EXTIME(3:4)//':'// & EXTIME(7:8)//'.'//EXTIME(9:10) END IF END IF CALL LIB$MOVC3(4,%REF(BUFFER(P:)),BROAD) P = 4 + P IF (BROAD.AND..NOT.SETPRV_PRIV().AND..NOT.OPER_PRIV()) THEN BROAD = 0 END IF CALL LIB$MOVC3(4,%REF(BUFFER(P:)),BELL) P = 4 + P CALL LIB$MOVC3(4,%REF(BUFFER(P:)),ALL) P = 4 + P CALL LIB$MOVC3(4,%REF(BUFFER(P:)),CLUSTER) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR CALL READDIR(0,IER) ! Get NBLOCK IF (IER.EQ.0) NBLOCK = 0 ! If new file, NBLOCK is 0 CALL OPEN_BULLFIL OENTRY = OUT_HEAD(UNIT_INDEX) LENGTH = LEN_SAVE(UNIT_INDEX) LEN_SAVE(UNIT_INDEX) = 0 DO I=1,LENGTH CALL READ_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) WRITE (1'NBLOCK+I) INQUEUE END DO IF (BROAD) THEN CALL GET_BROADCAST_MESSAGE(BELL) CALL BROADCAST(ALL,CLUSTER) END IF CALL CLOSE_BULLFIL ! Finished adding bulletin IF (BTEST(FOLDER_FLAG,14)) FROM = 'ANONYMOUS' CALL ADD_ENTRY ! Add the new directory entry CALL UPDATE_FOLDER ! Update info in folder file CALL CLOSE_BULLDIR ! Totally finished with add CALL WRITE_CHAN(LEN(FOLDER_COM),FOLDER_COM,UNIT_INDEX,IER) CALL SAVE_LAST_READ_BTIM(UNIT_INDEX) IF (.NOT.BROAD) GO TO 1000 100 CALL GETUSER(BULLCP_USER) ! Get present username CALL OPEN_BULLUSER_SHARED ! Broadcast on other nodes TEMP_USER = ':' DO WHILE (TEMP_USER(:1).EQ.':') DO WHILE (REC_LOCK(IER)) READ (4,KEYGT=TEMP_USER,IOSTAT=IER) & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG,USERNAME TEMP_USER = TEMP_USER(:TRIM(TEMP_USER)) IF (IER.EQ.0.AND. & (TEMP_USER(2:TRIM(TEMP_USER)).EQ.NODENAME & .OR..NOT.TEST2(NEW_FLAG,FOLDER_NUMBER)) & .AND.TEMP_USER(:1).EQ.':') THEN IER1 = REC_LOCK(IER) ! Skip the node that END IF ! originated the message END DO IF (TEMP_USER(:1).NE.':') THEN CALL CLOSE_BULLUSER CALL SETUSER(BULLCP_USER) REMOTE_SET = .FALSE. CLOSE (UNIT=REMOTE_UNIT) GO TO 1000 END IF CALL SETUSER(USERNAME) ! Reset to original username FOLDER1 = 'GENERAL' FOLDER1_BBOARD = ':'//TEMP_USER CALL CONNECT_REMOTE_FOLDER(READ_ONLY,IER) IF (IER.NE.0) THEN CALL ERRSNS(IDUMMY,IDUMMY,INODE) IF (INODE.EQ.%LOC(SS$_NOSUCHNODE).OR. & INODE.EQ.%LOC(SS$_NOSUCHOBJ).OR.INODE.EQ.0) THEN DELETE (4) END IF ELSE IER = 0 I = 1 DO WHILE (IER.EQ.0.AND.I.LT.BLENGTH) WRITE (REMOTE_UNIT,'(4A)',IOSTAT=IER) & 15,-1,I,BMESSAGE(I:MIN(BLENGTH,I+127)) I = I + 128 END DO IF (IER.EQ.0) WRITE (REMOTE_UNIT,'(5A)',IOSTAT=IER) & 15,BLENGTH,BELL,ALL,CLUSTER END IF END DO ELSE IF (CMD_TYPE.EQ.8) THEN ! Read directory entry CALL LIB$MOVC3(4,%REF(BUFFER(5:)),ICOUNT) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR_SHARED IF (ICOUNT.GE.0) THEN CALL READDIR(ICOUNT,IER) ELSE CALL LIB$MOVC3(8,%REF(BUFFER(9:)),%REF(MSG_KEY(1:))) CALL READDIR_KEYGE(IER) END IF CALL CLOSE_BULLDIR CALL LIB$MOVC3(4,IER,%REF(BUFFER(1:))) IF (ICOUNT.NE.0) THEN BUFFER(5:) = BULLDIR_ENTRY CALL WRITE_CHAN & (LEN(BULLDIR_ENTRY)+4,BUFFER,UNIT_INDEX,IER) ELSE BUFFER(5:) = BULLDIR_HEADER CALL WRITE_CHAN & (LEN(BULLDIR_HEADER)+4,BUFFER,UNIT_INDEX,IER) END IF ELSE IF (CMD_TYPE.EQ.13) THEN ! Read directory entry CALL LIB$MOVC3(4,%REF(BUFFER(5:)),SBULL) CALL LIB$MOVC3(4,%REF(BUFFER(9:)),EBULL) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR_SHARED OENTRY = OUT_HEAD(UNIT_INDEX) DO I=SBULL,EBULL,ISIGN(1,EBULL-SBULL) CALL READDIR(I,IER) INQUEUE = BULLDIR_ENTRY CALL WRITE_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) END DO CALL CLOSE_BULLDIR OENTRY = OUT_HEAD(UNIT_INDEX) REC_SAVE(UNIT_INDEX) = LEN(BULLDIR_ENTRY) LEN_SAVE(UNIT_INDEX) = ABS(EBULL - SBULL) + 1 CALL READ_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) OUT_SAVE(UNIT_INDEX) = OENTRY CALL WRITE_CHAN(REC_SAVE(UNIT_INDEX),INQUEUE,UNIT_INDEX,IER) ELSE IF (CMD_TYPE.EQ.9) THEN ! Write directory entry CALL LIB$MOVC3(4,%REF(BUFFER(5:)),ICOUNT) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR IF (ICOUNT.GT.0) THEN BULLDIR_ENTRY = BUFFER(9:) CALL WRITEDIR_NOCONV(ICOUNT,IER) ELSE BULLDIR_HEADER = BUFFER(9:) CALL WRITEDIR_NOCONV(ICOUNT,IER) END IF CALL CLOSE_BULLDIR ELSE IF (CMD_TYPE.EQ.4) THEN CALL LIB$MOVC3(4,%REF(BUFFER(5:)),BULL_DELETE) CALL LIB$MOVC3(4,%REF(BUFFER(9:)),IMMEDIATE) DESCRIP_TEMP = BUFFER(13:ILEN) FOLDER1 = FOLDER FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) CALL OPEN_BULLDIR CALL READDIR(BULL_DELETE,IER) IF (IER.EQ.BULL_DELETE.OR.DESCRIP.NE.DESCRIP_TEMP) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Cannot find message to delete.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 ELSE IF (USERNAME.NE.FROM.AND.FROM_SAVE(UNIT_INDEX).NE.FROM & .AND.FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Insufficient privileges to delete message.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 END IF CALL REMOVE_ENTRY & (BULL_DELETE,BULL_DELETE,BULL_DELETE,IMMEDIATE) CALL CLOSE_BULLDIR CALL WRITE_CHAN(LEN(FOLDER_COM),FOLDER_COM,UNIT_INDEX,IER) ELSE IF (CMD_TYPE.EQ.5) THEN ! Read message CALL LIB$MOVC3(4,%REF(BUFFER(5:)),ICOUNT) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR_SHARED CALL READDIR(ICOUNT,IER) CALL OPEN_BULLFIL_SHARED OENTRY = OUT_HEAD(UNIT_INDEX) DO I=BLOCK,BLOCK+LENGTH-1 READ (1'I,IOSTAT=IER) INQUEUE CALL WRITE_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) END DO CALL CLOSE_BULLFIL CALL CLOSE_BULLDIR OENTRY = OUT_HEAD(UNIT_INDEX) REC_SAVE(UNIT_INDEX) = 128 LEN_SAVE(UNIT_INDEX) = LENGTH CALL READ_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) OUT_SAVE(UNIT_INDEX) = OENTRY CALL WRITE_CHAN(REC_SAVE(UNIT_INDEX),INQUEUE,UNIT_INDEX,IER) CALL SAVE_LAST_READ_BTIM(UNIT_INDEX) ELSE IF (CMD_TYPE.EQ.10) THEN ! Replacing bulletin FOLDER1 = FOLDER FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR CALL LIB$MOVC3(56,%REF(BUFFER(5:)),%REF(DESCRIP_TEMP)) P = LEN(DESCRIP_TEMP) + 5 CALL LIB$MOVC3(4,%REF(BUFFER(P:)),ICOUNT) P = 4 + P CALL READDIR(ICOUNT,IER) IF (IER.EQ.ICOUNT.OR.DESCRIP_TEMP.NE.DESCRIP) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Cannot find message to replace.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 END IF CALL LIB$MOVC3(56,%REF(BUFFER(P:)),%REF(DESCRIP)) P = LEN(DESCRIP) + P CALL LIB$MOVC3(4,%REF(BUFFER(P:)),%REF(MSGTYPE)) P = 4 + P CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXDATE)) P = LEN(EXDATE) + P CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXTIME)) P = LEN(EXTIME) + P ALLOW = (FOLDER_OWNER.EQ.USERNAME).OR.SETPRV_PRIV() IF ((FOLDER_NUMBER.GT.0.AND.(BTEST(MSGTYPE,0).OR. & BTEST(MSGTYPE,2)).AND..NOT.BTEST(FOLDER_FLAG,2)).OR. & (USERNAME.NE.FROM.AND..NOT.ALLOW).OR. & ((MSGTYPE.AND..NOT.8).NE.0.AND..NOT.ALLOW)) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Insufficient privileges to replace message.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 END IF CALL READDIR(0,IER) ! Get NBLOCK CALL OPEN_BULLFIL NEW_LENGTH = LEN_SAVE(UNIT_INDEX) LEN_SAVE(UNIT_INDEX) = 0 OENTRY = OUT_HEAD(UNIT_INDEX) DO I=1,NEW_LENGTH CALL READ_QUEUE(%VAL(OENTRY),OENTRY,INQUEUE) WRITE (1'NBLOCK+I) INQUEUE END DO CALL CLOSE_BULLFIL ! Finished adding bulletin IF (NEW_LENGTH.GT.0) THEN NEMPTY = NEMPTY + LENGTH LENGTH = NEW_LENGTH BLOCK = NBLOCK + 1 END IF CALL WRITEDIR(ICOUNT,IER) NBLOCK = NBLOCK + NEW_LENGTH CALL WRITEDIR(0,IER) CALL UPDATE_DIR_HEADER(BTEST(MSGTYPE,3),BTEST(MSGTYPE,1), & BTEST(MSGTYPE,2),EXDATE,EXTIME) IF (BTEST(MSGTYPE,0)) THEN SYSTEM = IBSET(SYSTEM,0) ! System? ELSE SYSTEM = IBCLR(SYSTEM,0) ! General? END IF CALL WRITEDIR(ICOUNT,IER) CALL CLOSE_BULLDIR CALL WRITE_CHAN(LEN(FOLDER_COM),FOLDER_COM,UNIT_INDEX,IER) ELSE IF (CMD_TYPE.EQ.11) THEN ! Undeleting CALL LIB$MOVC3(4,%REF(BUFFER(5:)),BULL_DELETE) P = 4 + P CALL LIB$MOVC3(56,%REF(BUFFER(P:)),%REF(DESCRIP_TEMP)) P = LEN(DESCRIP_TEMP) + P FOLDER1 = FOLDER FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) CALL OPEN_BULLDIR CALL READDIR(BULL_DELETE,IER) IF (IER.EQ.BULL_DELETE.OR.DESCRIP.NE.DESCRIP_TEMP) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Cannot find message to undelete.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 ELSE IF (USERNAME.NE.FROM.AND.FROM_SAVE(UNIT_INDEX).NE.FROM & .AND.FOLDER_OWNER.NE.USERNAME.AND..NOT.SETPRV_PRIV()) THEN CALL CLOSE_BULLDIR BUFFER = 'ERROR: Insufficient privileges to undelete message.' CALL WRITE_CHAN(TRIM(BUFFER),BUFFER,UNIT_INDEX,IER) GO TO 1000 END IF CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXDATE)) P = LEN(EXDATE) + P CALL LIB$MOVC3(12,%REF(BUFFER(P:)),%REF(EXTIME)) P = LEN(EXTIME) + P CALL WRITEDIR(BULL_DELETE,IER) CALL CLOSE_BULLDIR CALL WRITE_CHAN(LEN(FOLDER_COM),FOLDER_COM,UNIT_INDEX,IER) ELSE IF (CMD_TYPE.EQ.12) THEN ! Find newest bulletin CALL SET_FOLDER_FILE(0) CALL OPEN_BULLDIR_SHARED CALL READDIR(0,IER) CALL GET_NEWEST_MSG(%REF(BUFFER(5:)),BULL_POINT) CALL CLOSE_BULLDIR CALL WRITE_CHAN(4,%DESCR(BULL_POINT),UNIT_INDEX,IER) ELSE IF (CMD_TYPE.EQ.14) THEN ! Register remote folder CALL LIB$MOVC3(4,%REF(BUFFER(5:)),FLAG) FOLDER1 = FOLDER FOLDER_NUMBER = -1 CALL SELECT_FOLDER(.FALSE.,IER) CALL OPEN_BULLUSER_SHARED TEMP_USER = ':'//NODENAME(:TRIM(NODENAME)) DO WHILE (REC_LOCK(IER)) READ (4,KEY=TEMP_USER,IOSTAT=IER) & TEMP_USER,LOGIN_BTIM,READ_BTIM,NEW_FLAG END DO IF (IER.NE.0) THEN DO I=1,FLONG NEW_FLAG (I) = 0 END DO END IF IF (FLAG) THEN CALL SET2(NEW_FLAG,FOLDER_NUMBER) ELSE CALL CLR2(NEW_FLAG,FOLDER_NUMBER) END IF IF (IER.EQ.0) THEN REWRITE (4) TEMP_USER, & LOGIN_BTIM,READ_BTIM,NEW_FLAG,USERNAME ELSE TEMP_USER = ':'//NODENAME(:TRIM(NODENAME)) WRITE (4) TEMP_USER, & LOGIN_BTIM,READ_BTIM,NEW_FLAG,USERNAME END IF CALL CLOSE_BULLUSER ELSE IF (CMD_TYPE.EQ.15) THEN ! Broadcast message CALL LIB$MOVC3(4,%REF(BUFFER(5:)),BLENGTH) CALL LIB$MOVC3(4,%REF(BUFFER(9:)),START) IF (BLENGTH.EQ.-1) THEN IF (SCRATCH(UNIT_INDEX).EQ.0) THEN CALL LIB$GET_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) END IF CALL LIB$MOVC3(ILEN-12,%REF(BUFFER(13:)), & %VAL(SCRATCH(UNIT_INDEX)+START-1)) ELSE CALL LIB$MOVC3(BLENGTH,%VAL(SCRATCH(UNIT_INDEX)), & %REF(BMESSAGE(1:))) CALL LIB$MOVC3(4,%REF(BUFFER(13:)),ALL) CALL LIB$MOVC3(4,%REF(BUFFER(17:)),CLUSTER) CALL LIB$FREE_VM(BRDCST_LIMIT,SCRATCH(UNIT_INDEX)) IF (ILEN.GT.20) THEN CALL LIB$MOVC3(4,%REF(BUFFER(21:)),FOLDER_NUMBER) FOLDER = BUFFER(44:) GO TO 100 ELSE IF (SETPRV_PRIV().OR.OPER_PRIV()) THEN CALL BROADCAST(ALL,CLUSTER) END IF END IF ELSE IF (CMD_TYPE.EQ.16) THEN ! Change folder nodename CALL OPEN_BULLFOLDER_SHARED IER = 0 DO WHILE (IER.EQ.0) CALL READ_FOLDER_FILE(IER) IF ('::'//BUFFER(5:TRIM(BUFFER(:12))).EQ. & FOLDER_BBOARD(:TRIM(BUFFER(:12))+2).AND.IER.EQ.0) THEN FOLDER_BBOARD(3:) = BUFFER(13:TRIM(BUFFER(:20))) CALL REWRITE_FOLDER_FILE(IER) END IF END DO CALL CLOSE_BULLFOLDER END IF 1000 CALL COPY2(PROCPRIV,BULLCP_PRIV) IF (FOLDER_DIRECTORY.NE.FOLDER2_DIRECTORY) THEN FOLDER_DIRECTORY = FOLDER2_DIRECTORY CALL ADD_DIRECTORIES END IF RETURN END SUBROUTINE UPDATE_REMOTE_USERINFO(UNIT_INDEX) IMPLICIT INTEGER (A-Z) INCLUDE 'BULLUSER.INC' INCLUDE 'BULLDIR.INC' INCLUDE 'BULLFOLDER.INC' PARAMETER MAXLINK = 20 COMMON /CONNECT_STATUS/ FOLDER_NUM(MAXLINK),OUT_NUM(MAXLINK) COMMON /CONNECT_STATUS/ USER_SAVE(MAXLINK),FOLDERNAME(MAXLINK) COMMON /CONNECT_STATUS/ FROM_SAVE(MAXLINK),PRIV_SAVE(2,MAXLINK) COMMON /CONNECT_STATUS/ NODE_SAVE(MAXLINK),OUT_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ REC_SAVE(MAXLINK),LEN_SAVE(MAXLINK) COMMON /CONNECT_STATUS/ LAST_SAVE(2,MAXLINK),LAST_SYS_SAVE(2,MAXLINK) CHARACTER USER_SAVE*12,FOLDERNAME*44,FROM_SAVE*12,NODE_SAVE*12 DIMENSION SAVE_BTIM(2) USERNAME = USER_SAVE(UNIT_INDEX) FOLDER_NUMBER = FOLDER_NUM(UNIT_INDEX) IF (USERNAME.EQ.'DECNET'.OR.FOLDER_NUMBER.LT.0) RETURN CALL OPEN_USERINFO DIFF = COMPARE_BTIM(LAST_READ_BTIM(1,FOLDER_NUMBER+1), & LAST_SAVE(1,UNIT_INDEX)) IF (DIFF.LT.0) THEN LAST_READ_BTIM(1,FOLDER_NUMBER+1) = LAST_SAVE(1,UNIT_INDEX) LAST_READ_BTIM(2,FOLDER_NUMBER+1) = LAST_SAVE(2,UNIT_INDEX) END IF IF (LAST_SYS_BTIM(1,FOLDER_NUMBER+1).EQ.0.AND. & LAST_SYS_BTIM(2,FOLDER_NUMBER+1).EQ.0.AND. & LAST_SYS_SAVE(1,UNIT_INDEX).NE.0.AND. & LAST_SYS_SAVE(2,UNIT_INDEX).NE.0) THEN DIFF1 = -1 ELSE IF (LAST_SYS_SAVE(1,UNIT_INDEX).NE.0.AND. & LAST_SYS_SAVE(2,UNIT_INDEX).NE.0) THEN DIFF1 = COMPARE_BTIM(LAST_SYS_BTIM(1,FOLDER_NUMBER+1), & LAST_SYS_SAVE(1,UNIT_INDEX)) ELSE DIFF1 = 0 END IF IF (DIFF1.LT.0) THEN LAST_SYS_BTIM(1,FOLDER_NUMBER+1) = LAST_SYS_SAVE(1,UNIT_INDEX) LAST_SYS_BTIM(2,FOLDER_NUMBER+1) = LAST_SYS_SAVE(2,UNIT_INDEX) END IF IF (DIFF1.LT.0.OR.DIFF.LT.0) CALL UPDATE_USERINFO RETURN ENTRY SAVE_LAST_READ_BTIM(UNIT_INDEX) CALL SYS_BINTIM(DATE//' '//TIME,SAVE_BTIM) DIFF = COMPARE_BTIM(LAST_SAVE(1,UNIT_INDEX),SAVE_BTIM) IF (DIFF.GE.0) RETURN LAST_SAVE(1,UNIT_INDEX) = SAVE_BTIM(1) LAST_SAVE(2,UNIT_INDEX) = SAVE_BTIM(2) RETURN ENTRY SAVE_LAST_SYS_BTIM(UNIT_INDEX) CALL SYS_BINTIM('-',SAVE_BTIM) ! Get today's date LAST_SYS_SAVE(1,UNIT_INDEX) = SAVE_BTIM(1) LAST_SYS_SAVE(2,UNIT_INDEX) = SAVE_BTIM(2) RETURN END SUBROUTINE CHECK_BULLETIN_PRIV(USERNAME) IMPLICIT INTEGER (A-Z) COMMON /PRIVILEGES/ PROCPRIV(2),NEEDPRIV(2) INCLUDE 'BULLFILES.INC' IER = SETPRV_PRIV() IF ((PROCPRIV(1).AND.NEEDPRIV(1)).EQ.0.AND. & (PROCPRIV(2).AND.NEEDPRIV(2)).EQ.0) THEN CALL CHECK_ACCESS(BULLUSER_FILE(:TRIM(BULLUSER_FILE)), & USERNAME,R_ACCESS,W_ACCESS) IF (R_ACCESS) CALL COPY2(PROCPRIV,NEEDPRIV) END IF RETURN END SUBROUTINE GETACC(ACCOUNT) C C SUBROUTINE GETACC C C FUNCTION: C To get account of present process. C OUTPUTS: C ACCOUNT - ACCOUNT owner of present process. C IMPLICIT INTEGER (A-Z) CHARACTER*(*) ACCOUNT ! Limit is 12 characters INCLUDE '($JPIDEF)' CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(LEN(ACCOUNT),JPI$_ACCOUNT,%LOC(ACCOUNT)) CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info RETURN END SUBROUTINE GETSTS(STS) C C SUBROUTINE GETSTS C C FUNCTION: C To get status of present process. This tells if its a batch process. C OUTPUTS: C STS - Status word of present process. C IMPLICIT INTEGER (A-Z) INCLUDE '($JPIDEF)' CALL INIT_ITMLST ! Initialize item list CALL ADD_2_ITMLST(4,JPI$_STS,%LOC(STS)) CALL END_ITMLST(GETJPI_ITMLST) ! Get address of itemlist IER = SYS$GETJPIW(,,,%VAL(GETJPI_ITMLST),,,,) ! Get info RETURN END INTEGER FUNCTION LNM_MODE_EXEC(FAB,RAB,LUN) IMPLICIT INTEGER (A-Z) INCLUDE '($FABDEF)' INCLUDE '($RABDEF)' RECORD /FABDEF/ FAB RECORD /RABDEF/ RAB FAB.FAB$B_ACMODES = ISHFT(1,FAB$V_LNM_MODE) STATUS = SYS$OPEN(FAB) IF (STATUS) STATUS = SYS$CONNECT(RAB) LNM_MODE_EXEC = STATUS END INTEGER FUNCTION REC_LOCK(IER) INCLUDE '($FORIOSDEF)' DATA INIT /.TRUE./ IF (INIT) THEN REC_LOCK = 1 INIT = .FALSE. ELSE IF (IER.EQ.FOR$IOS_SPERECLOC) THEN CALL WAIT_SEC('01') INIT = INIT + 2 IF (INIT.GT.60) THEN WRITE (6,'('' Bulletin aborting due to record lock'', & '' problem. Alert system administrator.'')') CALL EXIT END IF ELSE REC_LOCK = 0 INIT = .TRUE. END IF END IF RETURN END INTEGER FUNCTION TRIM(INPUT) CHARACTER*(*) INPUT DO TRIM=LEN(INPUT),1,-1 IF (INPUT(TRIM:TRIM).NE.' '.AND.INPUT(TRIM:TRIM).NE.CHAR(0)) RETURN END DO RETURN END SUBROUTINE SYS_GETMSG(IER) IMPLICIT INTEGER (A-Z) COMMON /WINDOW/ WINDOW CHARACTER*80 MESSAGE WINDOW = 1 CALL LIB$SYS_GETMSG(IER,,MESSAGE) WRITE (6,'(A)') MESSAGE RETURN END SUBROUTINE HELP(LIBRARY) IMPLICIT INTEGER (A-Z) CHARACTER*(*) LIBRARY COMMON /BULLPAR/ BULL_PARAMETER,LEN_P CHARACTER*64 BULL_PARAMETER IER = CLI$GET_VALUE('HELP_FOLDER',BULL_PARAMETER,LEN_P) IF (.NOT.IER) BULL_PARAMETER = ' ' CALL OUTPUT_HELP(BULL_PARAMETER(1:LEN_P),LIBRARY) RETURN END SUBROUTINE GET_NODE_INFO C C SUBROUTINE GET_NODE_INFO C C FUNCTION: Gets local node name and obtains node names from C command line. C IMPLICIT INTEGER (A-Z) EXTERNAL CLI$_ABSENT COMMON /NODE_INFO/ NODES,LOCAL_NODE_FOUND,NODE_NUM, & NODE_ERROR,POINT_NODE COMMON /TEMP_INPUT/ NODE_TEMP CHARACTER NODE_TEMP*256 CHARACTER*32 NODES(10) LOGICAL LOCAL_NODE_FOUND,NODE_ERROR CHARACTER LOCAL_NODE*32,PASSWORD*32,TEMP_USER*12 NODE_ERROR = .FALSE. LOCAL_NODE_FOUND = .FALSE. CALL LIB$SYS_TRNLOG('SYS$NODE',L_NODE,LOCAL_NODE) L_NODE = L_NODE - 2 ! Remove '::' IF (LOCAL_NODE(1:1).EQ.'_') THEN LOCAL_NODE = LOCAL_NODE(2:) L_NODE = L_NODE - 1 END IF NODE_NUM = 0 ! Initialize number of nodes IF (CLI$PRESENT('NODES')) THEN ! Decnet nodes specified? DO WHILE (CLI$GET_VALUE('NODES',NODE_TEMP) & .NE.%LOC(CLI$_ABSENT)) ! Get the specified nodes IER = SYS_TRNLNM(NODE_TEMP,NODE_TEMP) DO WHILE (TRIM(NODE_TEMP).GT.0) NODE_NUM = NODE_NUM + 1 COMMA = INDEX(NODE_TEMP,',') IF (COMMA.GT.0) THEN NODES(NODE_NUM) = NODE_TEMP(1:COMMA-1) NODE_TEMP = NODE_TEMP(COMMA+1:) ELSE NODES(NODE_NUM) = NODE_TEMP NODE_TEMP = ' ' END IF NLEN = TRIM(NODES(NODE_NUM)) I = INDEX(NODES(NODE_NUM),'::') TEMP_USER = ' ' IF (I.GT.0.AND.NLEN-I.EQ.1) THEN NLEN = NLEN - 2 NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN) ELSE IF (I.GT.0.AND.NLEN-I.GT.1) THEN TEMP_USER = NODES(NODE_NUM)(I+2:) NLEN = I - 1 NODES(NODE_NUM) = NODES(NODE_NUM)(:NLEN) POINT_NODE = NODE_NUM IER = 1 DO WHILE (IER.NE.0) WRITE(6,'('' Enter password for node '',2A)') & NODES(NODE_NUM)(:NLEN),CHAR(10) CALL GET_INPUT_NOECHO(PASSWORD) IF (TRIM(PASSWORD).EQ.0) THEN DO WHILE (NODE_NUM.GT.0) CLOSE(UNIT=9+NODE_NUM) NODE_NUM = NODE_NUM - 1 END DO NODE_ERROR = .TRUE. RETURN END IF OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(:NLEN)// & '"'//TEMP_USER(:TRIM(TEMP_USER))//' '// & PASSWORD(:TRIM(PASSWORD))//'"::'//'"TASK=BULLETIN"', & ACCESS='SEQUENTIAL',FORM='FORMATTED', & CARRIAGECONTROL='NONE',TYPE='NEW',IOSTAT=IER) IF (IER.NE.0) THEN WRITE (6,'('' ERROR: Password is invalid.'')') END IF END DO END IF IF (LOCAL_NODE(:L_NODE).EQ.NODES(NODE_NUM)(:NLEN)) THEN NODE_NUM = NODE_NUM - 1 LOCAL_NODE_FOUND = .TRUE. ELSE IF (TRIM(TEMP_USER).EQ.0) THEN POINT_NODE = NODE_NUM OPEN (UNIT=9+NODE_NUM,NAME=NODES(NODE_NUM)(:NLEN)// & '::"TASK=BULLETIN"',ACCESS='SEQUENTIAL',FORM='FORMATTED', & CARRIAGECONTROL='NONE',TYPE='NEW',IOSTAT=IER) IF (IER.NE.0) THEN DO WHILE (NODE_NUM.GT.0) CLOSE(UNIT=9+NODE_NUM) NODE_NUM = NODE_NUM - 1 END DO NODE_ERROR = .TRUE. RETURN END IF END IF END DO END DO ELSE LOCAL_NODE_FOUND = .TRUE. END IF RETURN END SUBROUTINE SET_FOLDER_FILE(NUM) C C SUBROUTINE SET_FOLDER_FILE C C FUNCTION: Sets folder file name. If NUM = 0, set FOLDER_FILE, C if = 1, set FOLDER1_FILE C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' IF (NUM.EQ.0) THEN CALL SET_FILE(FOLDER,FOLDER_FLAG,FOLDER_NUMBER,FOLDER_FILE) ELSE IF (NUM.EQ.1) THEN CALL SET_FILE(FOLDER1,FOLDER1_FLAG,FOLDER1_NUMBER,FOLDER1_FILE) END IF RETURN END SUBROUTINE SET_FILE(FOLDER,FOLDER_FLAG,FOLDER_NUMBER,FOLDER_FILE) C C SUBROUTINE SET_FILE C IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFILES.INC' CHARACTER*(*) FOLDER,FOLDER_FILE IF (.NOT.BTEST(FOLDER_FLAG,8)) THEN FOLDER_FILE = & FOLDER_DIRECTORY(:TRIM(FOLDER_DIRECTORY))//FOLDER ELSE FOLDER_FILE = NEWS_DIRECTORY(:TRIM(NEWS_DIRECTORY)-1)// & '.]' END IF RETURN END SUBROUTINE SET_BULLFIL IMPLICIT INTEGER (A-Z) INCLUDE 'BULLFOLDER.INC' INCLUDE 'BULLDIR.INC' COMMON /BULLFIL/ BULLFIL CHARACTER FILDATE*12 DATA UPDATE/.FALSE./, JUST_NAME/.FALSE./ UPDATE = .TRUE. JUST_NAME = .TRUE. ENTRY SET_BULLFIL_UPDATE UPDATE = .NOT.UPDATE JUST_NAME = .TRUE. ENTRY SET_BULLFIL_NAME JUST_NAME = .NOT.JUST_NAME IER = SYS$ASCTIM(,FILDATE,EX_BTIM,) IF (.NOT.IER.OR.FILDATE.EQ.'17-NOV-1858 ') & IER = SYS$ASCTIM(,FILDATE,,) IF (BULLFIL.EQ.1) FILDATE = EXDATE FILDATE = FILDATE(FIRST_ALPHA(FILDATE):) M = INDEX(FILDATE,'-') FOLDER1_FILE = FOLDER_FILE(:MINGT0(INDEX(FOLDER_FILE,'.]'), & INDEX(FOLDER_FILE,'.BULLNEWS')))//'BULLNEWS'// & FILDATE(INDEX(FILDATE,' ')-2:TRIM(FILDATE))//']'// & FILDATE(:M-1)//FILDATE(M+1:M+3) IF (FOLDER1_FILE.NE.FOLDER_FILE) THEN FOLDER_FILE = FOLDER1_FILE IF (JUST_NAME) THEN JUST_NAME = .FALSE. RETURN END IF IF (BULLFIL.GT.0) CALL CLOSE_BULLFIL IF (BULLFIL.EQ.-1) THEN BULLFIL = 1 CALL OPEN_BULLFIL ELSE IF (BULLFIL.EQ.-2) THEN BULLFIL = 2 CALL OPEN_BULLFIL_SHARED END IF END IF JUST_NAME = .FALSE. IF (UPDATE) THEN READ (1'1) NBLOCK REWRITE (1) NBLOCK + LENGTH UPDATE = .FALSE. END IF RETURN END INTEGER FUNCTION MINGT0(I,J) IMPLICIT INTEGER (A-Z) IF (I.LE.0) THEN MINGT0 = J ELSE IF (J.LE.0) THEN MINGT0 = I ELSE MINGT0 = MIN(I,J) END IF RETURN END